/* FILE: interp.c */

#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <time.h>
#include <math.h>

#include "globals.h"

#ifdef GC_BDW
#    include "gc/gc.h"
#    define malloc GC_malloc_atomic
#    define realloc GC_realloc
#    define free(X)
#endif

/* Manual style : 0=plain, 1=html, 2=latex */
static void helpdetail_();
static void undefs_();
static void make_manual(int style);
static void manual_list_();
static void manual_list_aux_();

#define ONEPARAM(NAME)                      \
    if (stk == NULL)                        \
    execerror("one parameter",NAME)
#define TWOPARAMS(NAME)                     \
    if (stk == NULL || stk->next == NULL)   \
    execerror("two parameters",NAME)
#define THREEPARAMS(NAME)                   \
    if (stk == NULL || stk->next == NULL    \
        || stk->next->next == NULL)         \
    execerror("three parameters",NAME)
#define FOURPARAMS(NAME)                    \
    if (stk == NULL || stk->next == NULL    \
        || stk->next->next == NULL          \
        || stk->next->next->next == NULL)   \
    execerror("four parameters",NAME)
#define FIVEPARAMS(NAME)                    \
    if (stk == NULL || stk->next == NULL    \
        || stk->next->next == NULL          \
        || stk->next->next->next == NULL    \
        || stk->next->next->next->next == NULL)     \
    execerror("four parameters",NAME)
#define ONEQUOTE(NAME)                      \
    if (stk->op != LIST_)                   \
    execerror("quotation as top parameter",NAME)
#define TWOQUOTES(NAME)                     \
    ONEQUOTE(NAME);                         \
    if (stk->next->op != LIST_)             \
    execerror("quotation as second parameter",NAME)
#define THREEQUOTES(NAME)                   \
    TWOQUOTES(NAME);                        \
    if (stk->next->next->op != LIST_)       \
    execerror("quotation as third parameter",NAME)
#define FOURQUOTES(NAME)                    \
    THREEQUOTES(NAME);                      \
    if (stk->next->next->next->op != LIST_) \
    execerror("quotation as fourth parameter",NAME)
#define SAME2TYPES(NAME)                    \
    if (stk->op != stk->next->op)           \
    execerror("two parameters of the same type",NAME)
#define STRING(NAME)                        \
    if (stk->op != STRING_)                 \
    execerror("string",NAME)
#define STRING2(NAME)                       \
    if (stk->next->op != STRING_)           \
    execerror("string as second parameter",NAME)
#define INTEGER(NAME)                       \
    if (stk->op != INTEGER_)                \
    execerror("integer",NAME)
#define INTEGER2(NAME)                      \
    if (stk->next->op != INTEGER_)          \
    execerror("integer as second parameter",NAME)
#define CHARACTER(NAME)                     \
    if (stk->op != CHAR_)                   \
    execerror("character",NAME)
#define INTEGERS2(NAME)                     \
    if (stk->op != INTEGER_ || stk->next->op != INTEGER_)   \
    execerror("two integers",NAME)
#define NUMERICTYPE(NAME)                   \
    if (stk->op != INTEGER_ && stk->op !=  CHAR_        \
      && stk->op != BOOLEAN_ )              \
    execerror("numeric",NAME)
#define NUMERIC2(NAME)                      \
    if (stk->next->op != INTEGER_ && stk->next->op != CHAR_)    \
    execerror("numeric second parameter",NAME)
#define FLOATABLE                       \
    (stk->op == INTEGER_ || stk->op == FLOAT_)
#define FLOATABLE2                      \
    ((stk->op == FLOAT_ && stk->next->op == FLOAT_) ||      \
    (stk->op == FLOAT_ && stk->next->op == INTEGER_) || \
    (stk->op == INTEGER_ && stk->next->op == FLOAT_))
#define FLOAT(NAME)                     \
    if (!FLOATABLE)                     \
    execerror("float or integer", NAME);
#define FLOAT2(NAME)                    \
    if (!(FLOATABLE2 || (stk->op == INTEGER_ && stk->next->op == INTEGER_))) \
    execerror("two floats or integers", NAME)
#define FLOATVAL                        \
    (stk->op == FLOAT_ ? stk->u.dbl : (double) stk->u.num)
#define FLOATVAL2                       \
    (stk->next->op == FLOAT_ ? stk->next->u.dbl : (double) stk->next->u.num)
#define FLOAT_U(OPER)                      \
    if (FLOATABLE) { UNARY(FLOAT_NEWNODE, OPER(FLOATVAL)); return; }
#define FLOAT_P(OPER)                       \
    if (FLOATABLE2) { BINARY(FLOAT_NEWNODE, OPER(FLOATVAL2, FLOATVAL)); return; }
#define FLOAT_I(OPER)                       \
    if (FLOATABLE2) { BINARY(FLOAT_NEWNODE, (FLOATVAL2) OPER (FLOATVAL)); return; }
#define FILE(NAME)                      \
    if (stk->op != FILE_ || stk->u.fil == NULL)         \
    execerror("file", NAME)
#define CHECKZERO(NAME)                     \
    if (stk->u.num == 0)                    \
    execerror("non-zero operand",NAME)
#define LIST(NAME)                          \
    if (stk->op != LIST_)                   \
    execerror("list",NAME)
#define LIST2(NAME)                         \
    if (stk->next->op != LIST_)             \
    execerror("list as second parameter",NAME)
#define USERDEF(NAME)                       \
    if (stk->op != USR_)                    \
    execerror("user defined symbol",NAME)
#define CHECKLIST(OPR,NAME)                 \
    if (OPR != LIST_)                       \
    execerror("internal list",NAME)
#define CHECKSETMEMBER(NODE,NAME)           \
    if ((NODE->op != INTEGER_ && NODE->op != CHAR_) ||      \
    NODE->u.num >= SETSIZE)                 \
    execerror("small numeric",NAME)
#define CHECKEMPTYSET(SET,NAME)             \
    if (SET == 0)                           \
    execerror("non-empty set",NAME)
#define CHECKEMPTYSTRING(STRING,NAME)       \
    if (*STRING == '\0')                    \
    execerror("non-empty string",NAME)
#define CHECKEMPTYLIST(LIST,NAME)           \
    if (LIST == NULL)                       \
    execerror("non-empty list",NAME)
#define INDEXTOOLARGE(NAME)                 \
    execerror("smaller index",NAME)
#define BADAGGREGATE(NAME)                  \
    execerror("aggregate parameter",NAME)
#define BADDATA(NAME)                       \
    execerror("different type",NAME)

#define DMP dump->u.lis
#define DMP1 dump1->u.lis
#define DMP2 dump2->u.lis
#define DMP3 dump3->u.lis
#define DMP4 dump4->u.lis
#define DMP5 dump5->u.lis
#define SAVESTACK  dump = LIST_NEWNODE(stk,dump)
#define SAVED1 DMP
#define SAVED2 DMP->next
#define SAVED3 DMP->next->next
#define SAVED4 DMP->next->next->next
#define SAVED5 DMP->next->next->next->next
#define SAVED6 DMP->next->next->next->next->next

#define POP(X) X = X->next

#define NULLARY(CONSTRUCTOR,VALUE)               \
    stk = CONSTRUCTOR(VALUE, stk)
#define UNARY(CONSTRUCTOR,VALUE)                 \
    stk = CONSTRUCTOR(VALUE, stk->next)
#define BINARY(CONSTRUCTOR,VALUE)                \
    stk = CONSTRUCTOR(VALUE, stk->next->next)
#define GNULLARY(TYPE,VALUE)                     \
    stk = newnode(TYPE,(VALUE),stk)
#define GUNARY(TYPE,VALUE)                       \
    stk = newnode(TYPE,(VALUE),stk->next)
#define GBINARY(TYPE,VALUE)                      \
    stk = newnode(TYPE,(VALUE),stk->next->next)
#define GTERNARY(TYPE,VALUE)                    \
    stk = newnode(TYPE,(VALUE),stk->next->next->next)

#define GETSTRING(NODE)                      \
  ( NODE->op == STRING_  ?  NODE->u.str :    \
   (NODE->op == USR_  ?  NODE->u.ent->name : \
    opername(NODE->op) ) )

/* - - - -  O P E R A N D S   - - - - */

#define PUSH(PROCEDURE,CONSTRUCTOR,VALUE)  \
static void PROCEDURE()                    \
{   NULLARY(CONSTRUCTOR,VALUE); }
PUSH(true_,BOOLEAN_NEWNODE,1L)
/* constants    */PUSH(false_,BOOLEAN_NEWNODE,0L)
PUSH(setsize_,INTEGER_NEWNODE,(long)SETSIZE)
PUSH(maxint_,INTEGER_NEWNODE,(long)MAXINT)
PUSH(symtabmax_,INTEGER_NEWNODE,(long)SYMTABMAX)
PUSH(memorymax_,INTEGER_NEWNODE,(long)MEMORYMAX)
PUSH(stdin_, FILE_NEWNODE, stdin)
PUSH(stdout_, FILE_NEWNODE, stdout)
PUSH(stderr_, FILE_NEWNODE, stderr)
PUSH(dump_,LIST_NEWNODE,dump)
/* variables    */PUSH(conts_,LIST_NEWNODE,LIST_NEWNODE(conts->u.lis->next,conts->next))
PUSH(symtabindex_,INTEGER_NEWNODE,(long)LOC2INT(symtabindex))
PUSH(rand_, INTEGER_NEWNODE, (long)rand())
/* this is now in utils.c
 PUSH(memoryindex_,INTEGER_NEWNODE,MEM2INT(memoryindex))
 */PUSH(echo_,INTEGER_NEWNODE,(long)echoflag)
PUSH(autoput_,INTEGER_NEWNODE,(long)autoput)
PUSH(undeferror_,INTEGER_NEWNODE,(long)undeferror)
PUSH(clock_,INTEGER_NEWNODE,(long)(clock() - startclock))
PUSH(time_,INTEGER_NEWNODE,(long)time(NULL))
PUSH(argc_,INTEGER_NEWNODE,(long)g_argc)

void stack_(void) {
    NULLARY(LIST_NEWNODE, stk);
}

/* - - - - -   O P E R A T O R S   - - - - - */

static void id_() {
    /* do nothing */
}
static void unstack_() {
    ONEPARAM("unstack");
    LIST("unstack");
    stk = stk->u.lis;
}

/* - - -   STACK   - - - */

static void name_() {
    ONEPARAM("name");
    UNARY(STRING_NEWNODE, stk->op == USR_ ? stk->u.ent->name : opername(stk->op));
}

static void intern_() {
    char *p;
    ONEPARAM("intern");
    STRING("intern");
    strcpy(id, stk->u.str);
    hashvalue = 0;
    for (p = id; *p; p++)
        hashvalue += *p;
    hashvalue %= HASHSIZE;
    lookup();
    if (location < firstlibra) {
        bucket.proc = location->u.proc;
        GUNARY(LOC2INT(location), bucket);
    } else
        UNARY(USR_NEWNODE, location);
}

static void getenv_() {
    ONEPARAM("getenv");
    STRING("getenv");
    UNARY(, getenv(stk->u.str));
}

static void body_() {
    ONEPARAM("body");
    USERDEF("body");
    UNARY(LIST_NEWNODE,stk->u.ent->u.body);
}
static void pop_() {
    ONEPARAM("pop");
    POP(stk);
}
static void swap_() {
    TWOPARAMS("swap");
    SAVESTACK;
    GBINARY(SAVED1->op,SAVED1->u);
    GNULLARY(SAVED2->op,SAVED2->u);
    POP(dump);
}
static void rollup_() {
    THREEPARAMS("rollup");
    SAVESTACK;
    GTERNARY(SAVED1->op,SAVED1->u);
    GNULLARY(SAVED3->op,SAVED3->u);
    GNULLARY(SAVED2->op,SAVED2->u);
    POP(dump);
}
static void rolldown_() {
    THREEPARAMS("rolldown");
    SAVESTACK;
    GTERNARY(SAVED2->op,SAVED2->u);
    GNULLARY(SAVED1->op,SAVED1->u);
    GNULLARY(SAVED3->op,SAVED3->u);
    POP(dump);
}
static void rotate_() {
    THREEPARAMS("rotate");
    SAVESTACK;
    GTERNARY(SAVED1->op,SAVED1->u);
    GNULLARY(SAVED2->op,SAVED2->u);
    GNULLARY(SAVED3->op,SAVED3->u);
    POP(dump);
}

static void dup_() {
    ONEPARAM("dup");
    GNULLARY(stk->op,stk->u);
}

#define DIPPED(PROCEDURE,NAME,PARAMCOUNT,ARGUMENT)              \
static void PROCEDURE()                                        \
{   PARAMCOUNT(NAME);                                           \
    SAVESTACK;                                                  \
    POP(stk);                                                   \
    ARGUMENT();                                                 \
    GNULLARY(SAVED1->op,SAVED1->u);                             \
    POP(dump);                                                  \
}
DIPPED(popd_,"popd",TWOPARAMS,pop_)
DIPPED(dupd_,"dupd",TWOPARAMS,dup_)
DIPPED(swapd_,"swapd",THREEPARAMS,swap_)
DIPPED(rolldownd_,"rolldownd",FOURPARAMS,rolldown_)
DIPPED(rollupd_,"rollupd",FOURPARAMS,rollup_)
DIPPED(rotated_,"rotated",FOURPARAMS,rotate_)

/* - - -   BOOLEAN   - - - */

#define ANDORXOR(PROCEDURE,NAME,OPER1,OPER2)            \
static void PROCEDURE()                 \
{   TWOPARAMS(NAME);                        \
    SAME2TYPES(NAME);                       \
    switch (stk->next->op)                  \
      { case SET_:                      \
        BINARY(SET_NEWNODE,(long)(stk->next->u.set OPER1 stk->u.set));  \
        return;                     \
    case BOOLEAN_: case CHAR_: case INTEGER_: case LIST_:   \
        BINARY(BOOLEAN_NEWNODE,(long)(stk->next->u.num OPER2 stk->u.num));  \
        return;                     \
    default:                        \
        BADDATA(NAME); } }
ANDORXOR(and_,"and",&,&&)
ANDORXOR(or_,"or",|,||)
ANDORXOR(xor_,"xor",^,!=)

/* - - -   INTEGER   - - - */

#define ORDCHR(PROCEDURE,NAME,RESULTTYP)   \
static void PROCEDURE()                 \
{   ONEPARAM(NAME);                     \
    NUMERICTYPE(NAME);                  \
    UNARY(RESULTTYP,stk->u.num);        \
}
ORDCHR(ord_,"ord",INTEGER_NEWNODE)
ORDCHR(chr_,"chr",CHAR_NEWNODE)

static void abs_() {
    ONEPARAM("abs");
    /* start new */FLOAT("abs");
    if (stk->op == INTEGER_) {
        if (stk->u.num >= 0)
            return;
        else {
            UNARY(INTEGER_NEWNODE, - stk->u.num);
            return;
        }
    }
    /* end new */FLOAT_U(fabs);
    INTEGER("abs");
    if (stk->u.num < 0)
        UNARY(INTEGER_NEWNODE, - stk->u.num);
}
static double fsgn(double f) {
    if (f < 0)
        return -1.0;
    else if (f > 0)
        return 1.0;
    else
        return 0.0;
}
static void sign_() {
    ONEPARAM("sign");
    /* start new */FLOAT("sign");
    if (stk->op == INTEGER_) {
        long i = stk->u.num;
        if (i == 0 || i == 1)
            return;
        else {
            UNARY(INTEGER_NEWNODE, i > 0 ? 1 : -1);
            return;
        }
    }
    /* end new */FLOAT_U(fsgn);
    INTEGER("sign");
    if (stk->u.num < 0)
        UNARY(INTEGER_NEWNODE,-1L);
    else if (stk->u.num > 0)
        UNARY(INTEGER_NEWNODE,1L);
}
static void neg_() {
    ONEPARAM("neg");
    FLOAT_U(-);
    INTEGER("neg");
    UNARY(INTEGER_NEWNODE, -stk->u.num);
}

static void mul_() {
    TWOPARAMS("*");
    FLOAT_I(*);
    INTEGERS2("*");
    BINARY(INTEGER_NEWNODE,stk->next->u.num * stk->u.num);
}
static void divide_() {
    TWOPARAMS("/");
    if (stk->op == FLOAT_ && stk->u.dbl == 0.0 || stk->op == INTEGER_ && stk->u.num == 0)
        execerror("non-zero divisor", "/");
    FLOAT_I(/);
    INTEGERS2("/");
    BINARY(INTEGER_NEWNODE,stk->next->u.num / stk->u.num);
}

static void rem_() {
    TWOPARAMS("rem");
    FLOAT_P(fmod);
    INTEGERS2("rem");
    CHECKZERO("rem");
    BINARY(INTEGER_NEWNODE,stk->next->u.num % stk->u.num);
}

static void div_() {
    ldiv_t result;
    TWOPARAMS("div");
    INTEGERS2("div");
    CHECKZERO("div");
    result = ldiv(stk->next->u.num, stk->u.num);
    BINARY(INTEGER_NEWNODE, result.quot);
    NULLARY(INTEGER_NEWNODE, result.rem);
}

static void strtol_() {
    TWOPARAMS("strtol");
    SAVESTACK;
    INTEGER("strtol");
    POP(stk);
    STRING("strtol");
    UNARY(INTEGER_NEWNODE, strtol(SAVED2->u.str, NULL, SAVED1->u.num));
    POP(dump);
}

static void strtod_() {
    ONEPARAM("strtod");
    STRING("strtod");
    UNARY(FLOAT_NEWNODE, strtod(stk->u.str, NULL));
}

static void format_() {
    int width, prec;
    char spec;
    char format[7];
    char *result;
    FOURPARAMS("format");
    INTEGER("format");
    INTEGER2("format");
    prec = stk->u.num;
    POP(stk);
    width = stk->u.num;
    POP(stk);
    CHARACTER("format");
    spec = stk->u.num;
    POP(stk);
    if (!strchr("dioxX", spec))
        execerror("one of: d i o x X", "format");
    strcpy(format, "%*.*ld");
    format[5] = spec;
    result = malloc(INPLINEMAX); /* should be sufficient */
    NUMERICTYPE("format");
    sprintf(result, format, width, prec, stk->u.num);
    UNARY(, result);
    return;
}

static void formatf_() {
    int width, prec;
    char spec;
    char format[7];
    char *result;
    FOURPARAMS("format");
    INTEGER("format");
    INTEGER2("format");
    prec = stk->u.num;
    POP(stk);
    width = stk->u.num;
    POP(stk);
    CHARACTER("format");
    spec = stk->u.num;
    POP(stk);
    if (!strchr("eEfgG", spec))
        execerror("one of: e E f g G", "format");
    strcpy(format, "%*.*lg");
    format[5] = spec;
    result = malloc(INPLINEMAX); /* should be sufficient */
    FLOAT("formatf");
    sprintf(result, format, width, prec, stk->u.dbl);
    UNARY(, result);
    return;
}

/* - - -   TIME   - - - */

#define UNMKTIME(PROCEDURE,NAME,FUNC)               \
static void PROCEDURE()                 \
{   struct tm *t;                       \
    long wday;                          \
    time_t timval;                      \
    ONEPARAM(NAME);                     \
    INTEGER(NAME);                      \
    timval = stk->u.num;                    \
    t = FUNC(&timval);                      \
    wday = t->tm_wday;                      \
    if (wday == 0) wday = 7;                    \
    dump1 = LIST_NEWNODE(NULL, dump1);          \
    DMP1 = INTEGER_NEWNODE(wday, DMP1);     \
    DMP1 = INTEGER_NEWNODE((long)t->tm_yday, DMP1); \
    DMP1 = BOOLEAN_NEWNODE((long)t->tm_isdst, DMP1);    \
    DMP1 = INTEGER_NEWNODE((long)t->tm_sec, DMP1);  \
    DMP1 = INTEGER_NEWNODE((long)t->tm_min, DMP1);  \
    DMP1 = INTEGER_NEWNODE((long)t->tm_hour, DMP1); \
    DMP1 = INTEGER_NEWNODE((long)t->tm_mday, DMP1); \
    DMP1 = INTEGER_NEWNODE((long)(t->tm_mon + 1), DMP1); \
    DMP1 = INTEGER_NEWNODE((long)(t->tm_year + 1900), DMP1); \
    UNARY(LIST_NEWNODE, DMP1);                      \
    POP(dump1);                         \
    return; }
UNMKTIME(localtime_,"localtime",localtime)
UNMKTIME(gmtime_,"gmtime",gmtime)

static void decode_time(struct tm *t) {
    Node *p;
    t->tm_year = t->tm_mon = t->tm_mday = t->tm_hour = t->tm_min = t->tm_sec = t->tm_isdst = t->tm_yday = t->tm_wday = 0;
    p = stk->u.lis;
    if (p && p->op == INTEGER_) {
        t->tm_year = p->u.num - 1900;
        POP(p);
    }
    if (p && p->op == INTEGER_) {
        t->tm_mon = p->u.num - 1;
        POP(p);
    }
    if (p && p->op == INTEGER_) {
        t->tm_mday = p->u.num;
        POP(p);
    }
    if (p && p->op == INTEGER_) {
        t->tm_hour = p->u.num;
        POP(p);
    }
    if (p && p->op == INTEGER_) {
        t->tm_min = p->u.num;
        POP(p);
    }
    if (p && p->op == INTEGER_) {
        t->tm_sec = p->u.num;
        POP(p);
    }
    if (p && p->op == BOOLEAN_) {
        t->tm_isdst = p->u.num;
        POP(p);
    }
    if (p && p->op == INTEGER_) {
        t->tm_yday = p->u.num;
        POP(p);
    }
    if (p && p->op == INTEGER_) {
        t->tm_wday = p->u.num;
        POP(p);
    }
    return;
}

static void mktime_() {
    struct tm t;
    ONEPARAM("mktime");
    LIST("mktime");
    decode_time(&t);
    UNARY(INTEGER_NEWNODE, (long)mktime(&t));
    return;
}

static void strftime_() {
    struct tm t;
    char *fmt;
    char *result;
    size_t length;
    TWOPARAMS("strftime");
    STRING("strftime");
    fmt = stk->u.str;
    POP(stk);
    LIST("strftime");
    decode_time(&t);
    length = strlen(fmt) * 3 + 1; /* should be sufficient */
    result = malloc(length);
    strftime(result, length, fmt, &t);
    UNARY(, result);
    return;
}

/* - - -   FLOAT   - - - */

#define UFLOAT(PROCEDURE,NAME,FUNC)             \
static void PROCEDURE()                 \
{   ONEPARAM(NAME);                     \
    FLOAT(NAME);                        \
    UNARY(FLOAT_NEWNODE, FUNC(FLOATVAL));               \
    return; }
UFLOAT(acos_,"acos",acos)
UFLOAT(asin_,"asin",asin)
UFLOAT(atan_,"atan",atan)
UFLOAT(ceil_,"ceil",ceil)
UFLOAT(cos_,"cos",cos)
UFLOAT(cosh_,"cosh",cosh)
UFLOAT(exp_,"exp",exp)
UFLOAT(floor_,"floor",floor)
UFLOAT(log_,"log",log)
UFLOAT(log10_,"log10",log10)
UFLOAT(sin_,"sin",sin)
UFLOAT(sinh_,"sinh",sinh)
UFLOAT(sqrt_,"sqrt",sqrt)
UFLOAT(tan_,"tan",tan)
UFLOAT(tanh_,"tanh",tanh)

#define BFLOAT(PROCEDURE,NAME,FUNC)             \
static void PROCEDURE()                 \
{   TWOPARAMS(NAME);                        \
    FLOAT2(NAME);                       \
    BINARY(FLOAT_NEWNODE, FUNC(FLOATVAL2, FLOATVAL));           \
    return; }
BFLOAT(atan2_,"atan2",atan2)
BFLOAT(pow_,"pow",pow)

static void frexp_() {
    int exp;
    ONEPARAM("frexp");
    FLOAT("frexp");
    UNARY(FLOAT_NEWNODE, frexp(FLOATVAL, &exp));
    NULLARY(INTEGER_NEWNODE, (long)exp);
    return;
}

static void modf_() {
    double exp;
    ONEPARAM("frexp");
    FLOAT("frexp");
    UNARY(FLOAT_NEWNODE, modf(FLOATVAL, &exp));
    NULLARY(FLOAT_NEWNODE, exp);
    return;
}

static void ldexp_() {
    long exp;
    TWOPARAMS("ldexp");
    INTEGER("ldexp");
    exp = stk->u.num;
    POP(stk);
    FLOAT("ldexp");
    UNARY(FLOAT_NEWNODE, ldexp(FLOATVAL, (int)exp));
    return;
}

static void trunc_() {
    ONEPARAM("trunc");
    FLOAT("trunc");
    UNARY(INTEGER_NEWNODE, (long)FLOATVAL);
}

/* - - -   NUMERIC   - - - */

#define PREDSUCC(PROCEDURE,NAME,OPER)               \
static void PROCEDURE()                 \
{   ONEPARAM(NAME);                     \
    NUMERICTYPE(NAME);                      \
    if (stk->op == CHAR_)                   \
    UNARY(CHAR_NEWNODE, stk->u.num OPER 1);         \
    else UNARY(INTEGER_NEWNODE, stk->u.num OPER 1); }
PREDSUCC(pred_,"pred",-)
PREDSUCC(succ_,"succ",+)

#define PLUSMINUS(PROCEDURE,NAME,OPER)              \
static void PROCEDURE()                 \
{   TWOPARAMS(NAME);                        \
    FLOAT_I(OPER);                      \
    INTEGER(NAME);                      \
    NUMERIC2(NAME);                     \
    if (stk->next->op == CHAR_)                 \
    BINARY(CHAR_NEWNODE, stk->next->u.num OPER stk->u.num); \
    else BINARY(INTEGER_NEWNODE, stk->next->u.num OPER stk->u.num); }
PLUSMINUS(plus_,"+",+)
PLUSMINUS(minus_,"-",-)

#define MAXMIN(PROCEDURE,NAME,OPER)             \
static void PROCEDURE()                 \
{   TWOPARAMS(NAME);                        \
    if (FLOATABLE2)                     \
      { BINARY(FLOAT_NEWNODE,                       \
        FLOATVAL OPER FLOATVAL2 ?               \
        FLOATVAL2 : FLOATVAL);              \
    return; }                       \
    SAME2TYPES(NAME);                       \
    NUMERICTYPE(NAME);                      \
    if (stk->op == CHAR_)                   \
    BINARY(CHAR_NEWNODE,                    \
        stk->u.num OPER stk->next->u.num ?          \
        stk->next->u.num : stk->u.num);         \
    else BINARY(INTEGER_NEWNODE,                    \
        stk->u.num OPER stk->next->u.num ?          \
        stk->next->u.num : stk->u.num); }
MAXMIN(max_,"max",<)
MAXMIN(min_,"min",>)

#define COMPREL(PROCEDURE,NAME,CONSTRUCTOR,OPR)             \
static void PROCEDURE()                 \
  { long comp = 0;                      \
    TWOPARAMS(NAME);                        \
    switch (stk->op)                        \
      { case BOOLEAN_: case CHAR_: case INTEGER_:       \
        if (FLOATABLE2)                 \
        comp = FLOATVAL2 - FLOATVAL OPR 0;      \
        else                        \
        comp = stk->next->u.num - stk->u.num OPR 0; \
        break;                      \
    case FLOAT_:                        \
        if (FLOATABLE2)                 \
        comp = FLOATVAL2 - FLOATVAL OPR 0;      \
        else                        \
        comp = 0;                   \
        break;                      \
    case SET_:                      \
      { int i = 0;                      \
        while ( i < SETSIZE &&              \
            ( (stk->next->u.set & 1 << i) ==        \
              (stk->u.set & 1 << i) )  )        \
        ++i;                        \
        if (i == SETSIZE) i = 0; else ++i;          \
        if (!(stk->u.set & 1 << i)) i = -i;         \
        comp = i OPR 0;                 \
        break; }                        \
    case LIST_:                     \
        BADDATA(NAME);                  \
    default:                        \
        if (stk->next->op == LIST_)             \
          BADDATA(NAME);                    \
        comp = strcmp(GETSTRING(stk->next), GETSTRING(stk)) \
           OPR 0;                   \
        break; }                        \
    stk = CONSTRUCTOR(comp, stk->next->next); }

COMPREL(eql_,"=",BOOLEAN_NEWNODE,==)
COMPREL(neql_,"!=",BOOLEAN_NEWNODE,!=)
COMPREL(less_,"<",BOOLEAN_NEWNODE,<)
COMPREL(leql_,"<=",BOOLEAN_NEWNODE,<=)
COMPREL(greater_,">",BOOLEAN_NEWNODE,>)
COMPREL(geql_,">=",BOOLEAN_NEWNODE,>=)
COMPREL(compare_,"compare",INTEGER_NEWNODE,+)

/* - - -   FILES AND STREAMS   - - - */

static void fopen_() {
    TWOPARAMS("fopen");
    STRING("fopen");
    STRING2("fopen");
    BINARY(FILE_NEWNODE, fopen(stk->next->u.str, stk->u.str));
    return;
}

static void fclose_() {
    ONEPARAM("fclose");
    if (stk->op == FILE_ && stk->u.fil == NULL) {
        POP(stk);
        return;
    }
    FILE("fclose");
    fclose(stk->u.fil);
    POP(stk);
    return;
}

static void fflush_() {
    ONEPARAM("fflush");
    FILE("fflush");
    fflush(stk->u.fil);
    return;
}

static void fremove_() {
    ONEPARAM("fremove");
    STRING("fremove");
    UNARY(BOOLEAN_NEWNODE, (long)!remove(stk->u.str));
    return;
}

static void frename_() {
    TWOPARAMS("frename");
    STRING("frename");
    STRING2("frename");
    BINARY(BOOLEAN_NEWNODE, (long)!rename(stk->next->u.str, stk->u.str));
    return;
}

#define FILEGET(PROCEDURE,NAME,CONSTRUCTOR,EXPR)            \
static void PROCEDURE()                 \
{   ONEPARAM(NAME);                     \
    FILE(NAME);                         \
    NULLARY(CONSTRUCTOR,EXPR);                      \
    return; }
FILEGET(feof_,"feof",BOOLEAN_NEWNODE,(long)feof(stk->u.fil))
FILEGET(ferror_,"ferror",BOOLEAN_NEWNODE,(long)ferror(stk->u.fil))
FILEGET(fgetch_,"fgetch",CHAR_NEWNODE,(long)getc(stk->u.fil))
FILEGET(ftell_,"ftell",INTEGER_NEWNODE,ftell(stk->u.fil))

static void fgets_() {
    int length = 0;
    int size = INPLINEMAX;
    char *buff = NULL;
    ONEPARAM("fgets");
    FILE("fgets");
    for (;;) {
        buff = realloc(buff, size);
        if (fgets(buff + length, size - length, stk->u.fil) == NULL) {
            buff[length] = 0;
            break;
        }
        if (strchr(buff, '\n'))
            break;
        length += strlen(buff);
        size = size * 2;
    }
    NULLARY(, buff);
    return;
}

static void fput_() {
    FILE *stm;
    TWOPARAMS("fput");
    if (stk->next->op != FILE_ || (stm = stk->next->u.fil) == NULL)
        execerror("file", "fput");
    writefactor(stk, stm);
    fprintf(stm, " ");
    POP(stk);
    return;
}

static void fputch_() {
    int ch;
    TWOPARAMS("fputch");
    INTEGER("fputch");
    ch = stk->u.num;
    POP(stk);
    FILE("fputch");
    putc(ch, stk->u.fil);
    return;
}

static void fputchars_() /* suggested by Heiko Kuhrt, as "fputstring_" */
{
    FILE *stm;
    TWOPARAMS("fputchars");
    if (stk->next->op != FILE_ || (stm = stk->next->u.fil) == NULL)
        execerror("file", "fputchars");
    fprintf(stm, stk->u.str);
    POP(stk);
    return;
}

static void fread_() {
    unsigned char *buf;
    long count;
    TWOPARAMS("fread");
    INTEGER("fread");
    count = stk->u.num;
    POP(stk);
    FILE("fread");
    buf = malloc(count);
    dump1 = LIST_NEWNODE(NULL, dump1);
    for (count = fread(buf, (size_t) 1, (size_t) count, stk->u.fil) - 1; count >= 0; count--)
        DMP1 = INTEGER_NEWNODE((long)buf[count], DMP1);
    free(buf);
    UNARY(LIST_NEWNODE, DMP1);
    POP(dump1);
    return;
}

static void fwrite_() {
    int length;
    int i;
    unsigned char *buff;
    Node *n;
    TWOPARAMS("fwrite");
    LIST("fwrite");
    for (n = stk->u.lis, length = 0; n; n = n->next, length++)
        if (n->op != INTEGER_)
            execerror("numeric list", "fwrite");
    buff = malloc(length);
    for (n = stk->u.lis, i = 0; n; n = n->next, i++)
        buff[i] = n->u.num;
    POP(stk);
    FILE("fwrite");
    fwrite(buff, (size_t) length, (size_t) 1, stk->u.fil);
    return;
}

static void fseek_() {
    long pos;
    int whence;
    THREEPARAMS("fseek");
    INTEGER("fseek");
    INTEGER2("fseek");
    whence = stk->u.num;
    POP(stk);
    pos = stk->u.num;
    POP(stk);
    FILE("fseek");
    NULLARY(BOOLEAN_NEWNODE, (long)!!fseek(stk->u.fil, pos, whence));
    return;
}

/* - - -   AGGREGATES   - - - */

static void first_() {
    ONEPARAM("first");
    switch (stk->op) {
    case LIST_:
        CHECKEMPTYLIST(stk->u.lis,"first");
        GUNARY(stk->u.lis->op,stk->u.lis->u);
        return;
    case STRING_:
        CHECKEMPTYSTRING(stk->u.str,"first");
        UNARY(CHAR_NEWNODE,(long)*(stk->u.str));
        return;
    case SET_: {
        long i = 0;
        CHECKEMPTYSET(stk->u.set,"first");
        while (!(stk->u.set & (1 << i)))
            i++;
        UNARY(INTEGER_NEWNODE,i);
        return;
    }
    default:
        BADAGGREGATE("first");
    }
}
static void rest_() {
    ONEPARAM("rest");
    switch (stk->op) {
    case SET_: {
        int i = 0;
        CHECKEMPTYSET(stk->u.set,"rest");
        while (!(stk->u.set & (1 << i)))
            i++;
        UNARY(SET_NEWNODE,stk->u.set & ~(1 << i));
        break;
    }
    case STRING_: {
        char *s = stk->u.str;
        CHECKEMPTYSTRING(s,"rest");
        UNARY(, ++s);
        break;
    }
    case LIST_:
        CHECKEMPTYLIST(stk->u.lis,"rest");
        UNARY(LIST_NEWNODE,stk->u.lis->next);
        return;
    default:
        BADAGGREGATE("rest");
    }
}
static void uncons_() {
    ONEPARAM("uncons");
    switch (stk->op) {
    case SET_: {
        long i = 0;
        long set = stk->u.set;
        CHECKEMPTYSET(set,"uncons");
        while (!(set & (1 << i)))
            i++;
        UNARY(INTEGER_NEWNODE,i);
        NULLARY(SET_NEWNODE,set & ~(1 << i));
        break;
    }
    case STRING_: {
        char *s = stk->u.str;
        CHECKEMPTYSTRING(s,"uncons");
        UNARY(CHAR_NEWNODE,(long)*s);
        NULLARY(,++s);
        break;
    }
    case LIST_:
        SAVESTACK;
        CHECKEMPTYLIST(SAVED1->u.lis,"uncons");
        GUNARY(SAVED1->u.lis->op,SAVED1->u.lis->u);
        NULLARY(LIST_NEWNODE,SAVED1->u.lis->next);
        POP(dump);
        return;
    default:
        BADAGGREGATE("uncons");
    }
}
static void unswons_() {
    ONEPARAM("unswons");
    switch (stk->op) {
    case SET_: {
        long i = 0;
        long set = stk->u.set;
        CHECKEMPTYSET(set,"unswons");
        while (!(set & (1 << i)))
            i++;
        UNARY(SET_NEWNODE,set & ~(1 << i));
        NULLARY(INTEGER_NEWNODE,i);
        break;
    }
    case STRING_: {
        char *s = stk->u.str;
        CHECKEMPTYSTRING(s,"unswons");
        UNARY(,++s);
        NULLARY(CHAR_NEWNODE,(long)*(--s));
        break;
    }
    case LIST_:
        SAVESTACK;
        CHECKEMPTYLIST(SAVED1->u.lis,"unswons");
        UNARY(LIST_NEWNODE,SAVED1->u.lis->next);
        GNULLARY(SAVED1->u.lis->op,SAVED1->u.lis->u);
        POP(dump);
        return;
    default:
        BADAGGREGATE("unswons");
    }
}
static long equal_aux(); /* forward */

static int equal_list_aux(n1, n2)
    Node *n1, *n2; {
    if (n1 == NULL && n2 == NULL)
        return 1;
    if (n1 == NULL || n2 == NULL)
        return 0;
    if (equal_aux(n1, n2))
        return equal_list_aux(n1->next, n2->next);
    else
        return 0;
}
static long equal_aux(n1, n2)
    Node *n1, *n2; {
    if (n1 == NULL && n2 == NULL)
        return 1;
    if (n1 == NULL || n2 == NULL)
        return 0;
    switch (n1->op) {
    case BOOLEAN_:
    case CHAR_:
    case INTEGER_:
        if (n2->op != BOOLEAN_ && n2->op != CHAR_ && n2->op != INTEGER_)
            return 0;
        return n1->u.num == n2->u.num;
    case SET_:
        if (n2->op != SET_)
            return 0;
        return n1->u.num == n2->u.num;
    case LIST_:
        if (n2->op != LIST_)
            return 0;
        return equal_list_aux(n1->u.lis, n2->u.lis);
    default:
        return strcmp(GETSTRING(n1), GETSTRING(n2)) == 0;
    }
}
static void equal_() {
    TWOPARAMS("equal");
    BINARY(BOOLEAN_NEWNODE,equal_aux(stk,stk->next));
}
#define INHAS(PROCEDURE,NAME,AGGR,ELEM)             \
static void PROCEDURE()                 \
{   int found = 0;                      \
    TWOPARAMS(NAME);                        \
    switch (AGGR->op)                       \
      { case SET_:                      \
        found = ((AGGR->u.set) & (1 << ELEM->u.num)) > 0;   \
        break;                      \
    case STRING_:                       \
      { char *s;                        \
        for (s = AGGR->u.str;               \
         *s != '\0' && *s != ELEM->u.num;       \
         s++);                      \
        found = *s != '\0';                 \
        break; }                        \
    case LIST_:                     \
      { Node *n = AGGR->u.lis;              \
        while (n != NULL && n->u.num != ELEM->u.num)    \
        n = n->next;                    \
        found = n != NULL;                  \
        break; }                        \
    default:                        \
        BADAGGREGATE(NAME); }               \
    BINARY(BOOLEAN_NEWNODE,(long)found);                    \
}
INHAS(in_,"in",stk,stk->next)
INHAS(has_,"has",stk->next,stk)

#define OF_AT(PROCEDURE,NAME,AGGR,INDEX)            \
static void PROCEDURE()                 \
{   TWOPARAMS(NAME);                        \
    if (INDEX->op != INTEGER_ || INDEX->u.num < 0)      \
    execerror("non-negative integer", NAME);        \
    switch (AGGR->op)                       \
      { case SET_:                      \
      { long i; int indx = INDEX->u.num;            \
        CHECKEMPTYSET(AGGR->u.set,NAME);            \
        for (i = 0; i < SETSIZE; i++)           \
          { if (AGGR->u.set & (1 << i))         \
          { if (indx == 0)              \
            {BINARY(INTEGER_NEWNODE,i); return;}        \
            indx--; } }                 \
        INDEXTOOLARGE(NAME);                \
        return; }                       \
    case STRING_:                       \
        if (strlen(AGGR->u.str) < INDEX->u.num)     \
        INDEXTOOLARGE(NAME);                \
        BINARY(CHAR_NEWNODE,(long)AGGR->u.str[INDEX->u.num]);       \
        return;                     \
    case LIST_:                     \
      { Node *n = AGGR->u.lis;  int i  = INDEX->u.num;  \
        CHECKEMPTYLIST(n,NAME);             \
        while (i > 0)                   \
          { if (n->next == NULL)                \
            INDEXTOOLARGE(NAME);            \
        n = n->next; i--; }             \
        GBINARY(n->op,n->u);                    \
        return; }                       \
    default:                        \
        BADAGGREGATE(NAME); }               \
}
OF_AT(of_,"of",stk,stk->next)
OF_AT(at_,"at",stk->next,stk)

static void choice_() {
    THREEPARAMS("choice");
    if (stk->next->next->u.num)
        stk = newnode(stk->next->op, stk->next->u, stk->next->next->next);
    else
        stk = newnode(stk->op, stk->u, stk->next->next->next);
}
static void case_() {
    Node *n;
    TWOPARAMS("case");
    LIST("case");
    n = stk->u.lis;
    CHECKEMPTYLIST(n,"case");
    while (n->next != NULL && n->u.lis->u.num != stk->next->u.num)
        n = n->next;
    /*
     printf("case : now execute : ");
     writefactor(n->u.lis, stdout); printf("\n");
     stk = stk->next->next;
     exeterm(n->next != NULL ? n->u.lis->next : n->u.lis);
     */
    if (n->next != NULL) {
        stk = stk->next->next;
        exeterm(n->u.lis->next);
    } else {
        stk = stk->next;
        exeterm(n->u.lis);
    }
}
static void opcase_() {
    Node *n;
    ONEPARAM("opcase");
    LIST("opcase");
    n = stk->u.lis;
    CHECKEMPTYLIST(n,"opcase");
    while (n->next != NULL && n->op == LIST_ && n->u.lis->op != stk->next->op)
        n = n->next;
    CHECKLIST(n->op,"opcase");
    UNARY(LIST_NEWNODE,
            n->next != NULL ? n->u.lis->next : n->u.lis);
}
#define CONS_SWONS(PROCEDURE,NAME,AGGR,ELEM)            \
static void PROCEDURE()                 \
{   TWOPARAMS(NAME);                        \
    switch (AGGR->op)                       \
      { case LIST_:                     \
        BINARY(LIST_NEWNODE,newnode(ELEM->op,           \
                 ELEM->u,AGGR->u.lis)); \
        break;                      \
    case SET_:                      \
        CHECKSETMEMBER(ELEM,NAME);              \
        BINARY(SET_NEWNODE,AGGR->u.set | (1 << ELEM->u.num));   \
        break;                      \
    case STRING_:                       \
      { char *s;                        \
        if (ELEM->op != CHAR_)              \
        execerror("character", NAME);           \
        s = (char *) malloc(strlen(AGGR->u.str) + 2);   \
        s[0] = ELEM->u.num;                 \
        strcpy(s + 1,AGGR->u.str);              \
        BINARY(,s);               \
        break; }                        \
    default:                        \
        BADAGGREGATE(NAME); }               \
}
CONS_SWONS(cons_,"cons",stk,stk->next)
CONS_SWONS(swons_,"swons",stk->next,stk)

static void drop_() {
    int n = stk->u.num;
    TWOPARAMS("drop");
    switch (stk->next->op) {
    case SET_: {
        int i;
        long result = 0;
        for (i = 0; i < SETSIZE; i++)
            if (stk->next->u.set & (1 << i)) {
                if (n < 1)
                    result = result | (1 << i);
                else
                    n--;
            }
        BINARY(SET_NEWNODE,result);
        return;
    }
    case STRING_: {
        char *result = stk->next->u.str;
        while (n-- > 0 && *result != '\0')
            ++result;
        BINARY(,result);
        return;
    }
    case LIST_: {
        Node *result = stk->next->u.lis;
        while (n-- > 0 && result != NULL)
            result = result->next;
        BINARY(LIST_NEWNODE,result);
        return;
    }
    default:
        BADAGGREGATE("drop");
    }
}

static void take_() {
    int n = stk->u.num;
    TWOPARAMS("take");
    switch (stk->next->op) {
    case SET_: {
        int i;
        long result = 0;
        for (i = 0; i < SETSIZE; i++)
            if (stk->next->u.set & (1 << i)) {
                if (n > 0) {
                    --n;
                    result = result | (1 << i);
                } else
                    break;
            }
        BINARY(SET_NEWNODE,result);
        return;
    }
    case STRING_: {
        int i;
        char *old, *p, *result;
        i = stk->u.num;
        old = stk->next->u.str;
        POP(stk);
        /* do not swap the order of the next two statements ! ! ! */
        if (i < 0)
            i = 0;
        if (i > strlen(old))
            return; /* the old string unchanged */
        p = result = (char *) malloc(strlen(old) - i + 1);
        while (i-- > 0)
            *p++ = *old++;
        UNARY(,result);
        return;
    }
    case LIST_: {
        int i = stk->u.num;
        if (i < 1) {
            BINARY(LIST_NEWNODE,NULL);
            return;
        } /* null string */
        dump1 = newnode(LIST_, stk->next->u, dump1);/* old  */
        dump2 = LIST_NEWNODE(0L, dump2); /* head */
        dump3 = LIST_NEWNODE(0L, dump3); /* last */
        while (DMP1 != NULL && i-- > 0) {
            if (DMP2 == NULL) /* first */
            {
                DMP2 = newnode(DMP1->op, DMP1->u, NULL);
                DMP3 = DMP2;
            } else /* further */
            {
                DMP3->next = newnode(DMP1->op, DMP1->u, NULL);
                DMP3 = DMP3->next;
            }
            DMP1 = DMP1->next;
        }
        DMP3->next = NULL;
        BINARY(LIST_NEWNODE,DMP2);
        POP(dump1);
        POP(dump2);
        POP(dump3);
        return;
    }
    default:
        BADAGGREGATE("take");
    }
}
static void concat_() {
    TWOPARAMS("concat");
    SAME2TYPES("concat");
    switch (stk->op) {
    case SET_:
        BINARY(SET_NEWNODE,stk->next->u.set | stk->u.set);
        return;
    case STRING_: {
        char *s, *p;
        s = p = (char *) malloc(strlen(stk->next->u.str) + strlen(stk->u.str) + 1);
        while ((*p++ = *(stk->next->u.str)++) != '\0')
            ;
        --p; /* don't want terminating null */
        while ((*p++ = *(stk->u.str)++) != '\0')
            ;
        BINARY(,s);
        return;
    }
    case LIST_:
        if (stk->next->u.lis == NULL) {
            BINARY(LIST_NEWNODE,stk->u.lis);
            return;
        }
        dump1 = LIST_NEWNODE(stk->next->u.lis,dump1);/* old  */
        dump2 = LIST_NEWNODE(0L,dump2); /* head */
        dump3 = LIST_NEWNODE(0L,dump3); /* last */
        while (DMP1 != NULL) {
            if (DMP2 == NULL) /* first */
            {
                DMP2 = newnode(DMP1->op, DMP1->u, NULL);
                DMP3 = DMP2;
            } else /* further */
            {
                DMP3->next = newnode(DMP1->op, DMP1->u, NULL);
                DMP3 = DMP3->next;
            };
            DMP1 = DMP1->next;
        }
        DMP3->next = stk->u.lis;
        BINARY(LIST_NEWNODE,DMP2);
        POP(dump1);
        POP(dump2);
        POP(dump3);
        return;
    default:
        BADAGGREGATE("concat");
    };
}
static void enconcat_() {
    THREEPARAMS("enconcat");
    SAME2TYPES("enconcat");
    swapd_();
    cons_();
    concat_();
}
static void null_() {
    ONEPARAM("null");
    switch (stk->op) {
    case STRING_:
        UNARY(BOOLEAN_NEWNODE, (long)(*(stk->u.str) == '\0'));
        break;
    case FLOAT_:
        UNARY(BOOLEAN_NEWNODE, (long)(stk->u.dbl == 0.0));
        break;
    case FILE_:
        UNARY(BOOLEAN_NEWNODE, (long)(stk->u.fil == NULL));
        break;
    default:
        UNARY(BOOLEAN_NEWNODE, (long)(! stk->u.num));
    }
}
static void not_() {
    ONEPARAM("not");
    switch (stk->op) {
    case SET_:
        UNARY(SET_NEWNODE,~ stk->u.set);
        break;
    case STRING_:
        UNARY(BOOLEAN_NEWNODE,(long)(*(stk->u.str) != '\0'));
        break;
    case BOOLEAN_:
    case CHAR_:
    case INTEGER_:
    case LIST_:
        UNARY(BOOLEAN_NEWNODE, (long)(! stk->u.num));
        break;
    default:
        BADDATA("not");
    }
}
static void size_() {
    long siz = 0;
    ONEPARAM("size");
    switch (stk->op) {
    case SET_: {
        int i;
        for (i = 0; i < SETSIZE; i++)
            if (stk->u.set & (1 << i))
                siz++;
        break;
    }
    case STRING_:
        siz = strlen(stk->u.str);
        break;
    case LIST_: {
        Node *e = stk->u.lis;
        while (e != NULL) {
            e = e->next;
            siz++;
        };
        break;
    }
    default:
        BADDATA("size");
    }
    UNARY(INTEGER_NEWNODE,siz);
}
static void small_() {
    long sml = 0;
    ONEPARAM("small");
    switch (stk->op) {
    case BOOLEAN_:
    case INTEGER_:
        sml = stk->u.num < 2;
        break;
    case SET_:
        if (stk->u.set == 0)
            sml = 1;
        else {
            int i = 0;
            while (!(stk->u.set & (1 << i)))
                i++;
            D( printf("small: first member found is %d\n",i); )
            sml = (stk->u.set & ~(1 << i)) == 0;
        }
        break;
    case STRING_:
        sml = stk->u.str[0] == '\0' || stk->u.str[1] == '\0';
        break;
    case LIST_:
        sml = stk->u.lis == NULL || stk->u.lis->next == NULL;
        break;
    default:
        BADDATA("small");
    }
    UNARY(BOOLEAN_NEWNODE,sml);
}
#define TYPE(PROCEDURE,NAME,REL,TYP)                \
    static void PROCEDURE()                 \
    {   ONEPARAM(NAME);                     \
    UNARY(BOOLEAN_NEWNODE,(long)(stk->op REL TYP)); }
TYPE(integer_,"integer",==,INTEGER_)
TYPE(char_,"char",==,CHAR_)
TYPE(logical_,"logical",==,BOOLEAN_)
TYPE(string_,"string",==,STRING_)
TYPE(set_,"set",==,SET_)
TYPE(list_,"list",==,LIST_)
TYPE(leaf_,"leaf",!=,LIST_)
TYPE(float_,"float",==,FLOAT_)
TYPE(file_,"file",==,FILE_)
TYPE(user_,"user",==,USR_)

#define USETOP(PROCEDURE,NAME,TYPE,BODY)            \
    static void PROCEDURE()                 \
    { ONEPARAM(NAME); TYPE(NAME); BODY; POP(stk); }
USETOP( put_,"put",ONEPARAM, writefactor(stk, stdout);printf(" "))
USETOP( putch_,"putch",NUMERICTYPE, printf("%c", (char) stk->u.num) )
USETOP( putchars_,"putchars",STRING, printf(stk->u.str) )
USETOP( setecho_,"setecho",NUMERICTYPE, echoflag = stk->u.num )
USETOP( setautoput_,"setautoput",NUMERICTYPE, autoput = stk->u.num )
USETOP( setundeferror_, "setundeferror", NUMERICTYPE, undeferror = stk->u.num )
USETOP( settracegc_,"settracegc",NUMERICTYPE, tracegc = stk->u.num )
USETOP( srand_,"srand",INTEGER, srand((unsigned int) stk->u.num) )
USETOP( include_,"include",STRING, doinclude(stk->u.str) )
USETOP( system_,"system",STRING, system(stk->u.str) )

static void undefs_(void) {
    Entry *i = symtabindex;
    Node *n = 0;
    while (i != symtab) {
        --i;
        if ((i->name[0] != 0) && (i->name[0] != '_') && (i->u.body == NULL))
            n = (i->name,n);
    }
    stk = LIST_NEWNODE(n,stk);
}
static void argv_() {
    int i;
    dump1 = LIST_NEWNODE(NULL, dump1);
    for (i = g_argc - 1; i >= 0; i--) {
        DMP1 = (g_argv[i], DMP1);
    }
    NULLARY(LIST_NEWNODE, DMP1);
    POP(dump1);
    return;
}

static void get_() {
    getsym();
    readfactor();
}

void dummy_(void) {
    /* never called */
}
#define HELP(PROCEDURE,REL)                 \
static void PROCEDURE()                 \
{   Entry *i = symtabindex;                 \
    int column = 0;                     \
    int name_length;                        \
    while (i != symtab)                     \
    if ((--i)->name[0] REL '_')             \
      { name_length = strlen(i->name) + 1;          \
        if (column + name_length > 72)      \
          { printf("\n"); column = 0; }         \
        printf("%s ", i->name);                 \
        column += name_length; }                \
    printf("\n"); }
HELP(help1_,!=)
HELP(h_help1_,==)

/* - - - - -   C O M B I N A T O R S   - - - - - */

void exeterm(Node *n) {
    Node *stepper;
    start: if (n == NULL)
        return;
    conts = LIST_NEWNODE(n,conts);
    while (conts->u.lis != NULL) {
        if (tracegc > 5) {
            printf("exeterm1: %ld ", (long) conts->u.lis);
            printnode(conts->u.lis);
        }
        stepper = conts->u.lis;
        conts->u.lis = conts->u.lis->next;
        switch (stepper->op) {
        case BOOLEAN_:
        case CHAR_:
        case INTEGER_:
        case FLOAT_:
        case SET_:
        case STRING_:
        case LIST_:
            stk = newnode(stepper->op, stepper->u, stk);
            break;
        case USR_:
            if (stepper->u.ent->u.body == NULL && undeferror)
                execerror("definition", stepper->u.ent->name);
            if (stepper->next == NULL) {
                POP(conts);
                n = stepper->u.ent->u.body;
                goto start;
            } else
                exeterm(stepper->u.ent->u.body);
            break;
        case COPIED_:
        case ILLEGAL_:
            printf("exeterm: attempting to execute bad node\n");
            printnode(stepper);
            break;
        default:
            D( printf("trying to do "); )
            D( writefactor(dump1, stdout); )
            (*(stepper->u.proc))();
            break;
        }
        if (tracegc > 5) {
            printf("exeterm2: %ld ", (long) stepper);
            printnode(stepper);
        }
        /*
         stepper = stepper->next; }
         */
    }
    POP(conts);
D( printf("after execution, stk is:\n"); )
D( writeterm(stk, stdout); )
D( printf("\n"); )
}
static void x_() {
    ONEPARAM("x");
    ONEQUOTE("x");
    exeterm(stk->u.lis);
}
static void i_() {
    ONEPARAM("i");
    ONEQUOTE("i");
    SAVESTACK;
    POP(stk);
    exeterm(SAVED1->u.lis);
    POP(dump);
}
static void dip_() {
    TWOPARAMS("dip");
    ONEQUOTE("dip");
    SAVESTACK;
    stk = stk->next->next;
    exeterm(SAVED1->u.lis);
    GNULLARY(SAVED2->op,SAVED2->u);
    POP(dump);
}
#define N_ARY(PROCEDURE,NAME,PARAMCOUNT,TOP)            \
static void PROCEDURE()                 \
{   PARAMCOUNT(NAME);                       \
    ONEQUOTE(NAME);                     \
    SAVESTACK;                          \
    POP(stk);                           \
    exeterm(SAVED1->u.lis);                 \
    if (stk == NULL) execerror("value to push",NAME);       \
    stk = newnode(stk->op, stk->u,TOP);             \
    POP(dump);                          \
}
N_ARY(nullary_,"nullary",ONEPARAM,SAVED2)
N_ARY(unary_,"unary",TWOPARAMS,SAVED3)
N_ARY(binary_,"binary",THREEPARAMS,SAVED4)
N_ARY(ternary_,"ternary",FOURPARAMS,SAVED5)

static void times_() {
    int i, n;
    TWOPARAMS("times");
    ONEQUOTE("times");
    INTEGER2("times");
    SAVESTACK;
    stk = stk->next->next;
    n = SAVED2->u.num;
    for (i = 1; i <= n; i++)
        exeterm(SAVED1->u.lis);
    POP(dump);
}
static void infra_() {
    TWOPARAMS("infra");
    ONEQUOTE("infra");
    LIST2("infra");
    SAVESTACK;
    stk = SAVED2->u.lis;
    exeterm(SAVED1->u.lis);
    stk = LIST_NEWNODE(stk,SAVED3);
    POP(dump);
}
static void app1_() {
    TWOPARAMS("app1");
    ONEQUOTE("app1");
    SAVESTACK;
    POP(stk);
    exeterm(SAVED1->u.lis);
    POP(dump);
}
static void cleave_() {
    /*  X [P1] [P2] cleave ==>  X1 X2   */
    THREEPARAMS("cleave");
    TWOQUOTES("cleave");
    SAVESTACK;
    stk = SAVED3;
    exeterm(SAVED2->u.lis); /* [P1]     */
    dump1 = newnode(stk->op, stk->u, dump1); /*  X1     */
    stk = SAVED3;
    exeterm(SAVED1->u.lis); /* [P2]     */
    dump1 = newnode(stk->op, stk->u, dump1); /*  X2     */
    stk = dump1;
    dump1 = dump1->next->next;
    stk->next->next = SAVED4;
    POP(dump);
}
static void app11_() {
    THREEPARAMS("app11");
    ONEQUOTE("app11");
    app1_();
    stk->next = stk->next->next;
}
static void unary2_() {
    /*   Y  Z  [P]  unary2     ==>  Y'  Z'  */
    THREEPARAMS("unary2");
    ONEQUOTE("unary2");
    SAVESTACK;
    stk = SAVED2->next; /* just Y on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save P(Y) */
    stk = newnode(SAVED2->op, SAVED2->u, SAVED3->next); /* just Z on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save P(Z) */
    stk = dump1;
    dump1 = dump1->next->next;
    stk->next->next = SAVED4;
    POP(dump);
}
static void unary3_() { /*  X Y Z [P]  unary3    ==>  X' Y' Z'  */
    FOURPARAMS("unary3");
    ONEQUOTE("unary3");
    SAVESTACK;
    stk = SAVED3->next; /* just X on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save p(X) */
    stk = newnode(SAVED3->op, SAVED3->u, SAVED4->next); /* just Y on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save P(Y) */
    stk = newnode(SAVED2->op, SAVED2->u, SAVED4->next); /* just Z on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save P(Z) */
    stk = dump1;
    dump1 = dump1->next->next->next;
    stk->next->next->next = SAVED5;
    POP(dump);
}
static void unary4_() {
    /*  X Y Z W [P]  unary4    ==>  X' Y' Z' W' */
    FIVEPARAMS("unary4");
    ONEQUOTE("unary4");
    SAVESTACK;
    stk = SAVED4->next; /* just X on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save p(X) */
    stk = newnode(SAVED4->op, SAVED4->u, SAVED5->next); /* just Y on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save P(Y) */
    stk = newnode(SAVED3->op, SAVED3->u, SAVED5->next); /* just Z on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save P(Z) */
    stk = newnode(SAVED2->op, SAVED2->u, SAVED5->next); /* just W on top */
    exeterm(SAVED1->u.lis); /* execute P */
    dump1 = newnode(stk->op, stk->u, dump1); /* save P(W) */
    stk = dump1;
    dump1 = dump1->next->next->next->next;
    stk->next->next->next->next = SAVED6;
    POP(dump);
}
static void app12_() {
    /*   X  Y  Z  [P]  app12  */
    THREEPARAMS("app12");
    unary2_();
    stk->next->next = stk->next->next->next; /* delete X */
}
static void map_() {
    TWOPARAMS("map");
    ONEQUOTE("map");
    SAVESTACK;
    switch (SAVED2->op) {
    case LIST_: {
        dump1 = newnode(LIST_, SAVED2->u, dump1); /* step old */
        dump2 = LIST_NEWNODE(0L,dump2); /* head new */
        dump3 = LIST_NEWNODE(0L,dump3); /* last new */
        while (DMP1 != NULL) {
            stk = newnode(DMP1->op, DMP1->u, SAVED3);
            exeterm(SAVED1->u.lis);
            D( printf("map: "); writefactor(stk, stdout); printf("\n"); )
            if (DMP2 == NULL) /* first */
            {
                DMP2 = newnode(stk->op, stk->u, NULL);
                DMP3 = DMP2;
            } else /* further */
            {
                DMP3->next = newnode(stk->op, stk->u, NULL);
                DMP3 = DMP3->next;
            }
            DMP1 = DMP1->next;
        }
        stk = LIST_NEWNODE(DMP2,SAVED3);
        POP(dump3);
        POP(dump2);
        POP(dump1);
        break;
    }
    case STRING_: {
        char *s, *resultstring;
        int j = 0;
        resultstring = (char *) malloc(strlen(SAVED2->u.str) + 1);
        for (s = SAVED2->u.str; *s != '\0'; s++) {
            stk = CHAR_NEWNODE((long)*s,SAVED3);
            exeterm(SAVED1->u.lis);
            resultstring[j++] = stk->u.num;
        }
        stk = (resultstring,SAVED3);
        break;
    }
    case SET_: {
        long i;
        long resultset = 0;
        for (i = 0; i < SETSIZE; i++)
            if (SAVED2->u.set & (1 << i)) {
                stk = INTEGER_NEWNODE(i,SAVED3);
                exeterm(SAVED1->u.lis);
                resultset = resultset | (1 << stk->u.num);
            }
        stk = SET_NEWNODE(resultset,SAVED3);
        break;
    }
    default:
        BADAGGREGATE("map");
    }
    POP(dump);
}
static void step_() {
    TWOPARAMS("step");
    ONEQUOTE("step");
    SAVESTACK;
    stk = stk->next->next;
    switch (SAVED2->op) {
    case LIST_: {
        dump1 = newnode(LIST_, SAVED2->u, dump1);
        while (DMP1 != NULL) {
            GNULLARY(DMP1->op,DMP1->u);
            exeterm(SAVED1->u.lis);
            DMP1 = DMP1->next;
        }
        POP(dump1);
        break;
    }
    case STRING_: {
        char *s;
        for (s = SAVED2->u.str; *s != '\0'; s++) {
            stk = CHAR_NEWNODE((long)*s,stk);
            exeterm(SAVED1->u.lis);
        }
        break;
    }
    case SET_: {
        long i;
        for (i = 0; i < SETSIZE; i++)
            if (SAVED2->u.set & (1 << i)) {
                stk = INTEGER_NEWNODE(i,stk);
                exeterm(SAVED1->u.lis);
            }
        break;
    }
    default:
        BADAGGREGATE("step");
    }
    POP(dump);
}
static void fold_() {
    THREEPARAMS("fold");
    swapd_();
    step_();
}
static void cond_() {
    int result = 0;
    ONEPARAM("cond");
    /* must check for QUOTES in list */LIST("cond");
    CHECKEMPTYLIST(stk->u.lis,"cond");
    SAVESTACK;
    dump1 = newnode(LIST_, stk->u, dump1);
    while (result == 0 && DMP1 != NULL && DMP1->next != NULL) {
        stk = SAVED2;
        exeterm(DMP1->u.lis->u.lis);
        result = stk->u.num;
        if (!result)
            DMP1 = DMP1->next;
    }
    stk = SAVED2;
    if (result)
        exeterm(DMP1->u.lis->next);
    else
        exeterm(DMP1->u.lis); /* default */
    POP(dump1);
    POP(dump);
}
#define IF_TYPE(PROCEDURE,NAME,TYP)             \
    static void PROCEDURE()                 \
    {   TWOPARAMS(NAME);                    \
    TWOQUOTES(NAME);                    \
        SAVESTACK;                      \
    stk = SAVED3;                       \
    exeterm(stk->op == TYP ? SAVED2->u.lis : SAVED1->u.lis);\
    POP(dump); }
IF_TYPE(ifinteger_,"ifinteger",INTEGER_)
IF_TYPE(ifchar_,"ifchar",CHAR_)
IF_TYPE(iflogical_,"iflogical",BOOLEAN_)
IF_TYPE(ifstring_,"ifstring",STRING_)
IF_TYPE(ifset_,"ifset",SET_)
IF_TYPE(iffloat_,"iffloat",FLOAT_)
IF_TYPE(iffile_,"iffile",FILE_)
IF_TYPE(iflist_,"iflist",LIST_)
static void filter_() {
    TWOPARAMS("filter");
    ONEQUOTE("filter");
    SAVESTACK;
    switch (SAVED2->op) {
    case SET_: {
        long j;
        long resultset = 0;
        for (j = 0; j < SETSIZE; j++) {
            if (SAVED2->u.set & (1 << j)) {
                stk = INTEGER_NEWNODE(j,SAVED3);
                exeterm(SAVED1->u.lis);
                if (stk->u.num)
                    resultset = resultset | (1 << j);
            }
        }
        stk = SET_NEWNODE(resultset,SAVED3);
        break;
    }
    case STRING_: {
        char *s, *resultstring;
        int j = 0;
        resultstring = (char *) malloc(strlen(SAVED2->u.str) + 1);
        for (s = SAVED2->u.str; *s != '\0'; s++) {
            stk = CHAR_NEWNODE((long)*s, SAVED3);
            exeterm(SAVED1->u.lis);
            if (stk->u.num)
                resultstring[j++] = *s;
        }
        resultstring[j] = '\0';
        stk = (resultstring,SAVED3);
        break;
    }
    case LIST_: {
        dump1 = newnode(LIST_, SAVED2->u, dump1); /* step old */
        dump2 = LIST_NEWNODE(0L,dump2); /* head new */
        dump3 = LIST_NEWNODE(0L,dump3); /* last new */
        while (DMP1 != NULL) {
            stk = newnode(DMP1->op, DMP1->u, SAVED3);
            exeterm(SAVED1->u.lis);
            D( printf("filter: "); writefactor(stk, stdout); printf("\n"); )
            if (stk->u.num) /* test */
            {
                if (DMP2 == NULL) /* first */
                {
                    DMP2 = newnode(DMP1->op, DMP1->u, NULL);
                    DMP3 = DMP2;
                } else /* further */
                {
                    DMP3->next = newnode(DMP1->op, DMP1->u, NULL);
                    DMP3 = DMP3->next;
                }
            }
            DMP1 = DMP1->next;
        }
        stk = LIST_NEWNODE(DMP2,SAVED3);
        POP(dump3);
        POP(dump2);
        POP(dump1);
        break;
    }
    default:
        BADAGGREGATE("filter");
    }
    POP(dump);
}
static void split_() {
    TWOPARAMS("split");
    SAVESTACK;
    switch (SAVED2->op) {
    case SET_: {
        long j;
        long yes_set = 0, no_set = 0;
        for (j = 0; j < SETSIZE; j++) {
            if (SAVED2->u.set & (1 << j)) {
                stk = INTEGER_NEWNODE(j,SAVED3);
                exeterm(SAVED1->u.lis);
                if (stk->u.num)
                    yes_set = yes_set | (1 << j);
                else
                    no_set = no_set | (1 << j);
            }
        }
        stk = SET_NEWNODE(yes_set,SAVED3);
        NULLARY(SET_NEWNODE,no_set);
        break;
    }
    case STRING_: {
        char *s, *yesstring, *nostring;
        int yesptr = 0, noptr = 0;
        yesstring = (char *) malloc(strlen(SAVED2->u.str) + 1);
        nostring = (char *) malloc(strlen(SAVED2->u.str) + 1);
        for (s = SAVED2->u.str; *s != '\0'; s++) {
            stk = CHAR_NEWNODE((long) *s, SAVED3);
            exeterm(SAVED1->u.lis);
            if (stk->u.num)
                yesstring[yesptr++] = *s;
            else
                nostring[noptr++] = *s;
        }
        yesstring[yesptr] = '\0';
        nostring[noptr] = '\0';
        stk = (yesstring,SAVED3);
        NULLARY(,nostring);
        break;
    }
    case LIST_: {
        dump1 = newnode(LIST_, SAVED2->u, dump1); /* step old */
        dump2 = LIST_NEWNODE(0L,dump2); /* head true */
        dump3 = LIST_NEWNODE(0L,dump3); /* last true */
        dump4 = LIST_NEWNODE(0L,dump4); /* head false */
        dump5 = LIST_NEWNODE(0L,dump5); /* last false */
        while (DMP1 != NULL) {
            stk = newnode(DMP1->op, DMP1->u, SAVED3);
            exeterm(SAVED1->u.lis);
            D( printf("split: "); writefactor(stk, stdout); printf("\n"); )
            if (stk->u.num) /* pass */
                if (DMP2 == NULL) /* first */
                {
                    DMP2 = newnode(DMP1->op, DMP1->u, NULL);
                    DMP3 = DMP2;
                } else /* further */
                {
                    DMP3->next = newnode(DMP1->op, DMP1->u, NULL);
                    DMP3 = DMP3->next;
                }
            else /* fail */
            if (DMP4 == NULL) /* first */
            {
                DMP4 = newnode(DMP1->op, DMP1->u, NULL);
                DMP5 = DMP4;
            } else /* further */
            {
                DMP5->next = newnode(DMP1->op, DMP1->u, NULL);
                DMP5 = DMP5->next;
            }
            DMP1 = DMP1->next;
        }
        stk = LIST_NEWNODE(DMP2,SAVED3);
        NULLARY(LIST_NEWNODE,DMP4);
        POP(dump5);
        POP(dump4);
        POP(dump3);
        POP(dump2);
        POP(dump1);
        break;
    }
    default:
        BADAGGREGATE("split");
    }
    POP(dump);
}
#define SOMEALL(PROCEDURE,NAME,INITIAL)             \
static void PROCEDURE()                 \
{   long result = INITIAL;                  \
    TWOPARAMS(NAME);                        \
    ONEQUOTE(NAME);                     \
    SAVESTACK;                          \
    switch (SAVED2->op)                     \
      { case SET_ :                     \
      { long j;                     \
        for (j = 0; j < SETSIZE && result == INITIAL; j++)  \
          { if (SAVED2->u.set & (1 << j))           \
          { stk = INTEGER_NEWNODE(j,SAVED3);        \
            exeterm(SAVED1->u.lis);         \
            if (stk->u.num != INITIAL)          \
            result = 1 - INITIAL; } }       \
        break; }                        \
    case STRING_ :                      \
      { char *s;                        \
        for (s = SAVED2->u.str;             \
         *s != '\0' && result == INITIAL; s++)      \
          { stk = CHAR_NEWNODE((long)*s,SAVED3);            \
        exeterm(SAVED1->u.lis);             \
        if (stk->u.num != INITIAL)          \
            result = 1 - INITIAL; }         \
        break; }                        \
    case LIST_ :                        \
      { dump1 = newnode(LIST_,SAVED2->u,dump1);     \
        while (DMP1 != NULL && result == INITIAL)   \
          { stk = newnode(DMP1->op,         \
            DMP1->u,SAVED3);        \
        exeterm(SAVED1->u.lis);             \
        if (stk->u.num != INITIAL)          \
             result = 1 - INITIAL;          \
        DMP1 = DMP1->next; }        \
        POP(dump1);             \
        break; }                        \
    default :                       \
        BADAGGREGATE(NAME); }               \
    stk = BOOLEAN_NEWNODE(result,SAVED3);           \
    POP(dump);                          \
}
SOMEALL(some_,"some",0L)
SOMEALL(all_,"all",1L)

static void primrec_() {
    int n = 0;
    int i;
    THREEPARAMS("primrec");
    SAVESTACK;
    stk = stk->next->next->next;
    switch (SAVED3->op) {
    case LIST_: {
        Node *current = SAVED3->u.lis;
        while (current != NULL) {
            stk = newnode(current->op, current->u, stk);
            current = current->next;
            n++;
        }
        break;
    }
    case STRING_: {
        char *s;
        for (s = SAVED3->u.str; *s != '\0'; s++) {
            stk = CHAR_NEWNODE((long) *s, stk);
            n++;
        }
        break;
    }
    case SET_: {
        long j;
        long set = SAVED3->u.set;
        for (j = 0; j < SETSIZE; j++)
            if (set & (1 << j)) {
                stk = INTEGER_NEWNODE(j,stk);
                n++;
            }
        break;
    }
    case INTEGER_: {
        long j;
        for (j = SAVED3->u.num; j > 0; j--) {
            stk = INTEGER_NEWNODE(j, stk);
            n++;
        }
        break;
    }
    default:
        BADDATA("primrec");
    }
    exeterm(SAVED2->u.lis);
    for (i = 1; i <= n; i++)
        exeterm(SAVED1->u.lis);
    POP(dump);
}
static void tailrecaux() {
    int result;
    tailrec: dump1 = LIST_NEWNODE(stk,dump1);
    exeterm(SAVED3->u.lis);
    result = stk->u.num;
    stk = DMP1;
    POP(dump1);
    if (result)
        exeterm(SAVED2->u.lis);
    else {
        exeterm(SAVED1->u.lis);
        goto tailrec;
    }
}
static void tailrec_() {
    THREEPARAMS("tailrec");
    SAVESTACK;
    stk = SAVED4;
    tailrecaux();
    POP(dump);
}
static void construct_() { /* [P] [[P1] [P2] ..] -> X1 X2 ..    */
    TWOPARAMS("construct");
    TWOQUOTES("construct");
    SAVESTACK;
    stk = SAVED3; /* pop progs      */
    dump1 = LIST_NEWNODE(dump2,dump1); /* save dump2        */
    dump2 = stk; /* save old stack  */
    exeterm(SAVED2->u.lis); /* [P]          */
    dump3 = LIST_NEWNODE(stk,dump3); /* save current stack  */
    dump4 = newnode(LIST_, SAVED1->u, dump4); /* step [..]  */
    while (DMP4 != NULL) {
        stk = DMP3; /* restore new stack    */
        exeterm(DMP4->u.lis);
        dump2 = newnode(stk->op, stk->u, dump2); /* result  */
        DMP4 = DMP4->next;
    }
    POP(dump4);
    POP(dump3);
    stk = dump2;
    dump2 = dump1->u.lis; /* restore dump2  */
    POP(dump1);
    POP(dump);
}
static void branch_() {
    THREEPARAMS("branch");
    TWOQUOTES("branch");
    SAVESTACK;
    stk = SAVED4;
    exeterm(SAVED3->u.num ? SAVED2->u.lis : SAVED1->u.lis);
    POP(dump);
}
static void while_() {
    TWOPARAMS("while");
    TWOQUOTES("while");
    SAVESTACK;
    do {
        stk = SAVED3;
        exeterm(SAVED2->u.lis); /* TEST */
        if (!stk->u.num)
            break;
        stk = SAVED3;
        exeterm(SAVED1->u.lis); /* DO */
        SAVED3 = stk;
    } while (1);
    stk = SAVED3;
    POP(dump);
}
static void ifte_() {
    int result;
    THREEPARAMS("ifte");
    THREEQUOTES("ifte");
    SAVESTACK;
    stk = SAVED4;
    exeterm(SAVED3->u.lis);
    result = stk->u.num;
    stk = SAVED4;
    exeterm(result ? SAVED2->u.lis : SAVED1->u.lis);
    POP(dump);
}
static void condlinrecaux() {
    int result = 0;
    dump1 = newnode(LIST_, SAVED1->u, dump1);
    dump2 = LIST_NEWNODE(stk,dump2);
    while (result == 0 && DMP1 != NULL && DMP1->next != NULL) {
        stk = DMP2;
        exeterm(DMP1->u.lis->u.lis);
        result = stk->u.num;
        if (!result)
            DMP1 = DMP1->next;
    }
    stk = DMP2;
    if (result) {
        exeterm(DMP1->u.lis->next->u.lis);
        if (DMP1->u.lis->next->next != NULL) {
            condlinrecaux();
            exeterm(DMP1->u.lis->next->next->u.lis);
        }
    } else {
        exeterm(DMP1->u.lis->u.lis);
        if (DMP1->u.lis->next != NULL) {
            condlinrecaux();
            exeterm(DMP1->u.lis->next->u.lis);
        }
    }
    POP(dump2);
    POP(dump1);
}
static void condlinrec_() {
    ONEPARAM("condlinrec");
    LIST("condlinrec");
    CHECKEMPTYLIST(stk->u.lis,"condlinrec");
    SAVESTACK;
    stk = SAVED2;
    condlinrecaux();
    POP(dump);
}
static void condnestrecaux() {
    int result = 0;
    dump1 = newnode(LIST_, SAVED1->u, dump1);
    dump2 = LIST_NEWNODE(stk,dump2);
    while (result == 0 && DMP1 != NULL && DMP1->next != NULL) {
        stk = DMP2;
        exeterm(DMP1->u.lis->u.lis);
        result = stk->u.num;
        if (!result)
            DMP1 = DMP1->next;
    }
    stk = DMP2;
    dump3 = LIST_NEWNODE(
            (result ? DMP1->u.lis->next : DMP1->u.lis),
            dump3 );
    exeterm(DMP3->u.lis);
    DMP3 = DMP3->next;
    while (DMP3 != NULL) {
        condnestrecaux();
        exeterm(DMP3->u.lis);
        DMP3 = DMP3->next;
    }
    POP(dump3);
    /*
     if (result)
     { exeterm(DMP1->u.lis->next->u.lis);
     if (DMP1->u.lis->next->next != NULL)
     { condnestrecaux();
     exeterm(DMP1->u.lis->next->next->u.lis); } }
     else
     { exeterm(DMP1->u.lis->u.lis);
     if (DMP1->u.lis->next != NULL)
     { condnestrecaux();
     exeterm(DMP1->u.lis->next->u.lis); } }
     */
    POP(dump2);
    POP(dump1);
}
static void condnestrec_() {
    ONEPARAM("condnestrec");
    LIST("condnestrec");
    CHECKEMPTYLIST(stk->u.lis,"condnestrec");
    SAVESTACK;
    stk = SAVED2;
    condnestrecaux();
    POP(dump);
}
static void linrecaux() {
    int result;
    dump1 = LIST_NEWNODE(stk,dump1);
    exeterm(SAVED4->u.lis);
    result = stk->u.num;
    stk = DMP1;
    POP(dump1);
    if (result)
        exeterm(SAVED3->u.lis);
    else {
        exeterm(SAVED2->u.lis);
        linrecaux();
        exeterm(SAVED1->u.lis);
    }
}
static void linrec_() {
    FOURPARAMS("linrec");
    FOURQUOTES("linrec");
    SAVESTACK;
    stk = SAVED5;
    linrecaux();
    POP(dump);
}
static void binrecaux() {
    int result;
    dump1 = LIST_NEWNODE(stk,dump1);
    exeterm(SAVED4->u.lis);
    result = stk->u.num;
    stk = DMP1;
    POP(dump1);
    if (result)
        exeterm(SAVED3->u.lis);
    else {
        exeterm(SAVED2->u.lis); /* split */
        dump2 = newnode(stk->op, stk->u, dump2);
        POP(stk);
        binrecaux(); /* first */
        GNULLARY(dump2->op,dump2->u);
        POP(dump2);
        binrecaux(); /* second */
        exeterm(SAVED1->u.lis);
    } /* combine */
}
static void binrec_() {
    FOURPARAMS("binrec");
    FOURQUOTES("binrec");
    SAVESTACK;
    stk = SAVED5;
    binrecaux();
    POP(dump);
}
static void treestepaux(item)
    Node *item; {
    if (item->op != LIST_) {
        GNULLARY(item->op,item->u);
        exeterm(SAVED1->u.lis);
    } else {
        dump1 = newnode(LIST_, item->u, dump1);
        while (DMP1 != NULL) {
            treestepaux(DMP1);
            DMP1 = DMP1->next;
        }
        POP(dump1);
    }
}
static void treestep_() {
    TWOPARAMS("treestep");
    ONEQUOTE("treestep");
    SAVESTACK;
    stk = SAVED3;
    treestepaux(SAVED2);
    POP(dump);
}
static void treerecaux() {
    if (stk->next->op == LIST_) {
        NULLARY(LIST_NEWNODE,ANON_FUNCT_NEWNODE(treerecaux,NULL));
        cons_(); /*  D  [[[O] C] ANON_FUNCT_]   */
        D( printf("treerecaux: stack = "); )
        D( writeterm(stk, stdout); printf("\n"); )
        exeterm(stk->u.lis->u.lis->next);
    } else {
        Node *n = stk;
        POP(stk);
        exeterm(n->u.lis->u.lis);
    }
}
static void treerec_() {
    THREEPARAMS("treerec");
    cons_();
    D( printf("deep: stack = "); writeterm(stk, stdout); printf("\n"); )
    treerecaux();
}
static void genrecaux() {
    int result;
    D( printf("genrecaux: stack = "); )
    D( writeterm(stk, stdout); printf("\n"); )
    SAVESTACK;
    POP(stk);
    exeterm(SAVED1->u.lis->u.lis); /*   [I] */
    result = stk->u.num;
    stk = SAVED2;
    if (result)
        exeterm(SAVED1->u.lis->next->u.lis); /* [T] */
    else {
        exeterm(SAVED1->u.lis->next->next->u.lis); /*   [R1]    */
        NULLARY(LIST_NEWNODE,SAVED1->u.lis);
        NULLARY(LIST_NEWNODE,ANON_FUNCT_NEWNODE(genrecaux,NULL));
        cons_();
        exeterm(SAVED1->u.lis->next->next->next);
    } /*   [R2] */
    POP(dump);
}
static void genrec_() {
    FOURPARAMS("genrec");
    FOURQUOTES("genrec");
    cons_();
    cons_();
    cons_();
    genrecaux();
}
static void treegenrecaux() {
    D( printf("treegenrecaux: stack = "); )
    D( writeterm(stk, stdout); printf("\n"); )
    if (stk->next->op == LIST_) {
        SAVESTACK; /* begin DIP */
        POP(stk);
        exeterm(SAVED1->u.lis->next->u.lis); /* [O2]    */
        GNULLARY(SAVED1->op,SAVED1->u);
        POP(dump); /*   end DIP */
        NULLARY(LIST_NEWNODE,ANON_FUNCT_NEWNODE(treegenrecaux,NULL));
        cons_();
        exeterm(stk->u.lis->u.lis->next->next);
    } /*    [C] */
    else {
        Node *n = stk;
        POP(stk);
        exeterm(n->u.lis->u.lis);
    } /*    [O1]    */
}
static void treegenrec_() { /* T [O1] [O2] [C]  */
    FOURPARAMS("treegenrec");
    cons_();
    cons_();
    D( printf("treegenrec: stack = "); writeterm(stk, stdout); printf("\n"); )
    treegenrecaux();
}

static void plain_manual_() {
    make_manual(0);
}
static void html_manual_() {
    make_manual(1);
}
static void latex_manual_() {
    make_manual(2);
}
static void manual_list_aux_() {
    manual_list_();
}

/* - - - - -   I N I T I A L I S A T I O N   - - - - - */

static struct {
    char *name;
    void (*proc)();
    char *messg1, *messg2;
}
optable[] =
            /* THESE MUST BE DEFINED IN THE ORDER OF THEIR VALUES */
            {

                { "__ILLEGAL", dummy_, "->", "internal error, cannot happen - supposedly." },
                { "__COPIED", dummy_, "->", "no message ever, used for gc." },
                { "__USR", dummy_, "usg", "user node." },
                { "__ANON_FUNCT", dummy_, "->", "op for anonymous function call." },

                /* LITERALS */
                { " truth value type", dummy_, "->  B", "The logical type, or the type of truth values.\nIt has just two literals: true and false." },
                { " character type", dummy_, "->  C", "The type of characters. Literals are written with a single quote.\nExamples:  'A  '7  ';  and so on. Unix style escapes are allowed." },

                { " integer type", dummy_, "->  I", "The type of negative, zero or positive integers.\nLiterals are written in decimal notation. Examples:  -123   0   42." },
                { " set type", dummy_, "->  {...}", "The type of sets of small non-negative integers.\nThe maximum is platform dependent, typically the range is 0..31.\nLiterals are written inside curly braces.\nExamples:  {}  {0}  {1 3 5}  {19 18 17}." },
                { " string type", dummy_, "->  \"...\" ", "The type of strings of characters. Literals are written inside double quotes.\nExamples: \"\"  \"A\"  \"hello world\" \"123\".\nUnix style escapes are accepted." },
                { " list type", dummy_, "->  [...]", "The type of lists of values of any type (including lists),\nor the type of quoted programs which may contain operators or combinators.\nLiterals of this type are written inside square brackets.\nExamples: []  [3 512 -7]  [john mary]  ['A 'C ['B]]  [dup *]." },
                { " float type", dummy_, "->  F", "The type of floating-point numbers.\nLiterals of this type are written with embedded decimal points (like 1.2)\nand optional exponent specifiers (like 1.5E2)" },
                { " file type", dummy_, "->  FILE:", "The type of references to open I/O streams,\ntypically but not necessarily files.\nThe only literals of this type are stdin, stdout, and stderr." },

                { "false", false_, "->  false", "Pushes the value false." },
                { "true", true_, "->  true", "Pushes the value true." },
                { "maxint", maxint_, "->  maxint", "Pushes largest integer (platform dependent). Typically it is 32 bits." },
                { "setsize", setsize_, "->  setsize", "Pushes the maximum number of elements in a set (platform dependent).\nTypically it is 32, and set members are in the range 0..31." },
                { "stack", stack_, ".. X Y Z  ->  .. X Y Z [Z Y X ..]", "Pushes the stack as a list." },
                { "__symtabmax", symtabmax_, "->", "Pushes value of maximum size of the symbol table." },
                { "__symtabindex", symtabindex_, "->", "Pushes current size of the symbol table." },
                { "__dump", dump_, "->", "debugging only: pushes the dump as a list." },
                { "conts", conts_, "->  [[P] [Q] ..]", "Pushes current continuations. Buggy, do not use." },
                { "autoput", autoput_, "->  I", "Pushes current value of flag  for automatic output, I = 0..2." },
                { "undeferror", undeferror_, "->  I", "Pushes current value of undefined-is-error flag." },
                { "undefs", undefs_, "->", "Push a list of all undefined symbols in the current symbol table." },
                { "echo", echo_, "->  I", "Pushes value of echo flag, I = 0..3." },
                { "clock", clock_, "->  I", "Pushes the integer value of current CPU usage in hundreds of a second." },
                { "time", time_, "->  I", "Pushes the current time (in seconds since the Epoch)." },
                { "rand", rand_, "  -> I", "I is a random integer." },
                { "__memorymax", memorymax_, "->", "Pushes value of total size of memory." },
                { "stdin", stdin_, "->  S", "Pushes the standard input stream." },
                { "stdout", stdout_, "->  S", "Pushes the standard output stream." },
                { "stderr", stderr_, "->  S", "Pushes the standard error stream." },

                /* OPERATORS */
                { "id", id_, "->", "Identity function, does nothing.\nAny program of the form  P id Q  is equivalent to just  P Q." },
                { "dup", dup_, " X  ->   X X", "Pushes an extra copy of X onto stack." },
                { "swap", swap_, " X Y  ->   Y X", "Interchanges X and Y on top of the stack." },
                { "rollup", rollup_, "X Y Z  ->  Z X Y", "Moves X and Y up, moves Z down" },
                { "rolldown", rolldown_, "X Y Z  ->  Y Z X", "Moves Y and Z down, moves X up" },
                { "rotate", rotate_, "X Y Z  ->  Z Y X", "Interchanges X and Z" },
                { "popd", popd_, "Y Z  ->  Z", "As if defined by:   popd  ==  [pop] dip " },
                { "dupd", dupd_, "Y Z  ->  Y Y Z", "As if defined by:   dupd  ==  [dup] dip" },
                { "swapd", swapd_, "X Y Z  ->  Y X Z", "As if defined by:   swapd  ==  [swap] dip" },
                { "rollupd", rollupd_, "X Y Z W  ->  Z X Y W", "As if defined by:   rollupd  ==  [rollup] dip" },
                { "rolldownd", rolldownd_, "X Y Z W  ->  Y Z X W", "As if defined by:   rolldownd  ==  [rolldown] dip " },
                { "rotated", rotated_, "X Y Z W  ->  Z Y X W", "As if defined by:   rotated  ==  [rotate] dip" },
                { "pop", pop_, " X  ->", "Removes X from top of the stack." },
                { "choice", choice_, "B T F  ->  X", "If B is true, then X = T else X = F." },
                { "or", or_, "X Y  ->  Z", "Z is the union of sets X and Y, logical disjunction for truth values." },
                { "xor", xor_, "X Y  ->  Z", "Z is the symmetric difference of sets X and Y,\nlogical exclusive disjunction for truth values." },
                { "and", and_, "X Y  ->  Z", "Z is the intersection of sets X and Y, logical conjunction for truth values." },
                { "not", not_, "X  ->  Y", "Y is the complement of set X, logical negation for truth values." },
                { "+", plus_, "M I  ->  N", "Numeric N is the result of adding integer I to numeric M.\nAlso supports float." },
                { "-", minus_, "M I  ->  N", "Numeric N is the result of subtracting integer I from numeric M.\nAlso supports float." },
                { "*", mul_, "I J  ->  K", "Integer K is the product of integers I and J.  Also supports float." },
                { "/", divide_, "I J  ->  K", "Integer K is the (rounded) ratio of integers I and J.  Also supports float." },
                { "rem", rem_, "I J  ->  K", "Integer K is the remainder of dividing I by J.  Also supports float." },
                { "div", div_, "I J  ->  K L", "Integers K and L are the quotient and remainder of dividing I by J." },
                { "sign", sign_, "N1  ->  N2", "Integer N2 is the sign (-1 or 0 or +1) of integer N1,\nor float N2 is the sign (-1.0 or 0.0 or 1.0) of float N1." },
                { "neg", neg_, "I  ->  J", "Integer J is the negative of integer I.  Also supports float." },
                { "ord", ord_, "C  ->  I", "Integer I is the Ascii value of character C (or logical or integer)." },
                { "chr", chr_, "I  ->  C", "C is the character whose Ascii value is integer I (or logical or character)." },
                { "abs", abs_, "N1  ->  N2", "Integer N2 is the absolute value (0,1,2..) of integer N1,\nor float N2 is the absolute value (0.0 ..) of float N1" },
                { "acos", acos_, "F  ->  G", "G is the arc cosine of F." },
                { "asin", asin_, "F  ->  G", "G is the arc sine of F." },
                { "atan", atan_, "F  ->  G", "G is the arc tangent of F." },
                { "atan2", atan2_, "F G  ->  H", "H is the arc tangent of F / G." },
                { "ceil", ceil_, "F  ->  G", "G is the float ceiling of F." },
                { "cos", cos_, "F  ->  G", "G is the cosine of F." },
                { "cosh", cosh_, "F  ->  G", "G is the hyperbolic cosine of F." },
                { "exp", exp_, "F  ->  G", "G is e (2.718281828...) raised to the Fth power." },
                { "floor", floor_, "F  ->  G", "G is the floor of F." },
                { "frexp", frexp_, "F  ->  G I", "G is the mantissa and I is the exponent of F.\nUnless F = 0, 0.5 <= abs(G) < 1.0." },
                { "ldexp", ldexp_, "F I  -> G", "G is F times 2 to the Ith power." },
                { "log", log_, "F  ->  G", "G is the natural logarithm of F." },
                { "log10", log10_, "F  ->  G", "G is the common logarithm of F." },
                { "modf", modf_, "F  ->  G H", "G is the fractional part and H is the integer part\n(but expressed as a float) of F." },
                { "pow", pow_, "F G  ->  H", "H is F raised to the Gth power." },
                { "sin", sin_, "F  ->  G", "G is the sine of F." },
                { "sinh", sinh_, "F  ->  G", "G is the hyperbolic sine of F." },
                { "sqrt", sqrt_, "F  ->  G", "G is the square root of F." },
                { "tan", tan_, "F  ->  G", "G is the tangent of F." },
                { "tanh", tanh_, "F  ->  G", "G is the hyperbolic tangent of F." },
                { "trunc", trunc_, "F  ->  I", "I is an integer equal to the float F truncated toward zero." },
                { "localtime", localtime_, "I  ->  T", "Converts a time I into a list T representing local time:\n[year month day hour minute second isdst yearday weekday].\nMonth is 1 = January ... 12 = December;\nisdst is a Boolean flagging daylight savings/summer time;\nweekday is 0 = Monday ... 7 = Sunday." },
                { "gmtime", gmtime_, "I  ->  T", "Converts a time I into a list T representing universal time:\n[year month day hour minute second isdst yearday weekday].\nMonth is 1 = January ... 12 = December;\nisdst is false; weekday is 0 = Monday ... 7 = Sunday." },
                { "mktime", mktime_, "T  ->  I", "Converts a list T representing local time into a time I.\nT is in the format generated by localtime." },
                { "strftime", strftime_, "T S1  ->  S2", "Formats a list T in the format of localtime or gmtime\nusing string S1 and pushes the result S2." },
                { "strtol", strtol_, "S I  ->  J", "String S is converted to the integer J using base I.\nIf I = 0, assumes base 10,\nbut leading \"0\" means base 8 and leading \"0x\" means base 16." },
                { "strtod", strtod_, "S  ->  R", "String S is converted to the float R." },
                { "format", format_, "N C I J  ->  S", "S is the formatted version of N in mode C\n('d or 'i = decimal, 'o = octal, 'x or\n'X = hex with lower or upper case letters)\nwith maximum width I and minimum width J." },
                { "formatf", formatf_, "F C I J  ->  S", "S is the formatted version of F in mode C\n('e or 'E = exponential, 'f = fractional,\n'g or G = general with lower or upper case letters)\nwith maximum width I and precision J." },
                { "srand", srand_, "I  ->  ", "Sets the random integer seed to integer I." },
                { "pred", pred_, "M  ->  N", "Numeric N is the predecessor of numeric M." },
                { "succ", succ_, "M  ->  N", "Numeric N is the successor of numeric M." },
                { "max", max_, "N1 N2  ->  N", "N is the maximum of numeric values N1 and N2.  Also supports float." },
                { "min", min_, "N1 N2  ->  N", "N is the minimum of numeric values N1 and N2.  Also supports float." },
                { "fclose", fclose_, "S  ->  ", "Stream S is closed and removed from the stack." },
                { "feof", feof_, "S  ->  S B", "B is the end-of-file status of stream S." },
                { "ferror", ferror_, "S  ->  S B", "B is the error status of stream S." },
                { "fflush", fflush_, "S  ->  S", "Flush stream S, forcing all buffered output to be written." },
                { "fgetch", fgetch_, "S  ->  S C", "C is the next available character from stream S." },
                { "fgets", fgets_, "S  ->  S L", "L is the next available line (as a string) from stream S." },
                { "fopen", fopen_, "P M  ->  S", "The file system object with pathname P is opened with mode M (r, w, a, etc.)\nand stream object S is pushed; if the open fails, file:NULL is pushed." },
                { "fread", fread_, "S I  ->  S L", "I bytes are read from the current position of stream S\nand returned as a list of I integers." },
                { "fwrite", fwrite_, "S L  ->  S", "A list of integers are written as bytes to the current position of stream S." },
                { "fremove", fremove_, "P  ->  B", "The file system object with pathname P is removed from the file system.\n is a boolean indicating success or failure." },
                { "frename", frename_, "P1 P2  ->  B", "The file system object with pathname P1 is renamed to P2.\nB is a boolean indicating success or failure." },
                { "fput", fput_, "S X  ->  S", "Writes X to stream S, pops X off stack." },
                { "fputch", fputch_, "S C  ->  S", "The character C is written to the current position of stream S." },
                { "fputchars", fputchars_, "S \"abc..\"  ->  S",
                        "The string abc.. (no quotes) is written to the current position of stream S." },
                { "fputstring", fputchars_, "S \"abc..\"  ->  S", "== fputchars, as a temporary alternative." },
                { "fseek", fseek_, "S P W  ->  S",
                        "Stream S is repositioned to position P relative to whence-point W,\nwhere W = 0, 1, 2 for beginning, current position, end respectively." },

                { "ftell", ftell_, "S  ->  S I", "I is the current position of stream S." },
                { "unstack", unstack_, "[X Y ..]  ->  ..Y X", "The list [X Y ..] becomes the new stack." },
                { "cons", cons_, "X A  ->  B", "Aggregate B is A with a new member X (first member for sequences)." },
                { "swons", swons_, "A X  ->  B", "Aggregate B is A with a new member X (first member for sequences)." },
                { "first", first_, "A  ->  F", "F is the first member of the non-empty aggregate A." },
                { "rest", rest_, "A  ->  R", "R is the non-empty aggregate A with its first member removed." },
                { "compare", compare_, "A B  ->  I",
                        "I (=-1,0,+1) is the comparison of aggregates A and B.\nThe values correspond to the predicates <=, =, >=." },

                { "at", at_, "A I  ->  X", "X (= A[I]) is the member of A at position I." },

                { "of", of_, "I A  ->  X", "X (= A[I]) is the I-th member of aggregate A." },

                { "size", size_, "A  ->  I", "Integer I is the number of elements of aggregate A." },

                { "opcase", opcase_, "X [..[X Xs]..]  ->  [Xs]", "Indexing on type of X, returns the list [Xs]." },

                { "case", case_, "X [..[X Y]..]  ->  Y i", "Indexing on the value of X, execute the matching Y." },

                { "uncons", uncons_, "A  ->  F R", "F and R are the first and the rest of non-empty aggregate A." },

                { "unswons", unswons_, "A  ->  R F", "R and F are the rest and the first of non-empty aggregate A." },

                { "drop", drop_, "A N  ->  B", "Aggregate B is the result of deleting the first N elements of A." },

                { "take", take_, "A N  ->  B", "Aggregate B is the result of retaining just the first N elements of A." },

                { "concat", concat_, "S T  ->  U", "Sequence U is the concatenation of sequences S and T." },

                { "enconcat", enconcat_, "X S T  ->  U",
                        "Sequence U is the concatenation of sequences S and T\nwith X inserted between S and T (== swapd cons concat)" },

                { "name", name_, "sym  ->  \"sym\"",
                        "For operators and combinators, the string \"sym\" is the name of item sym,\nfor literals sym the result string is its type." },

                { "intern", intern_, "\"sym\"  -> sym", "Pushes the item whose name is \"sym\"." },

                { "body", body_, "U  ->  [P]", "Quotation [P] is the body of user-defined symbol U." },

                /* PREDICATES */

                { "null", null_, "X  ->  B", "Tests for empty aggregate X or zero numeric." },

                { "small", small_, "X  ->  B", "Tests whether aggregate X has 0 or 1 members, or numeric 0 or 1." },

                { ">=", geql_, "X Y  ->  B",
                        "Either both X and Y are numeric or both are strings or symbols.\nTests whether X greater than or equal to Y.  Also supports float." },

                { ">", greater_, "X Y  ->  B",
                        "Either both X and Y are numeric or both are strings or symbols.\nTests whether X greater than Y.  Also supports float." },

                { "<=", leql_, "X Y  ->  B",
                        "Either both X and Y are numeric or both are strings or symbols.\nTests whether X less than or equal to Y.  Also supports float." },

                { "<", less_, "X Y  ->  B",
                        "Either both X and Y are numeric or both are strings or symbols.\nTests whether X less than Y.  Also supports float." },

                { "!=", neql_, "X Y  ->  B",
                        "Either both X and Y are numeric or both are strings or symbols.\nTests whether X not equal to Y.  Also supports float." },

                { "=", eql_, "X Y  ->  B",
                        "Either both X and Y are numeric or both are strings or symbols.\nTests whether X equal to Y.  Also supports float." },

                { "equal", equal_, "T U  ->  B", "(Recursively) tests whether trees T and U are identical." },

                { "has", has_, "A X  ->  B", "Tests whether aggregate A has X as a member." },

                { "in", in_, "X A  ->  B", "Tests whether X is a member of aggregate A." },

                { "integer", integer_, "X  ->  B", "Tests whether X is an integer." },

                { "char", char_, "X  ->  B", "Tests whether X is a character." },

                { "logical", logical_, "X  ->  B", "Tests whether X is a logical." },

                { "set", set_, "X  ->  B", "Tests whether X is a set." },

                { "string", string_, "X  ->  B", "Tests whether X is a string." },

                { "list", list_, "X  ->  B", "Tests whether X is a list." },

                { "leaf", leaf_, "X  ->  B", "Tests whether X is not a list." },

                { "user", user_, "X  ->  B", "Tests whether X is a user-defined symbol." },

                { "float", float_, "R  ->  B", "Tests whether R is a float." },

                { "file", file_, "F  ->  B", "Tests whether F is a file." },

                /* COMBINATORS */

                { "i", i_, "[P]  ->  ...", "Executes P. So, [P] i  ==  P." },

                { "x", x_, "[P]i  ->  ...", "Executes P without popping [P]. So, [P] x  ==  [P] P." },

                { "dip", dip_, "X [P]  ->  ... X", "Saves X, executes P, pushes X back." },

                { "app1", app1_, "X [P]  ->  R", "Executes P, pushes result R on stack without X." },

                { "app11", app11_, "X Y [P]  ->  R", "Executes P, pushes result R on stack." },

                { "app12", app12_, "X Y1 Y2 [P]  ->  R1 R2", "Executes P twice, with Y1 and Y2, returns R1 and R2." },

                { "construct", construct_, "[P] [[P1] [P2] ..]  ->  R1 R2 ..",
                        "Saves state of stack and then executes [P].\nThen executes each [Pi] to give Ri pushed onto saved stack." },

                { "nullary", nullary_, "[P]  ->  R",
                        "Executes P, which leaves R on top of the stack.\nNo matter how many parameters this consumes, none are removed from the stack." },

                { "unary", unary_, "X [P]  ->  R",
                        "Executes P, which leaves R on top of the stack.\nNo matter how many parameters this consumes,\nexactly one is removed from the stack." },

                { "unary2", unary2_, "X1 X2 [P]  ->  R1 R2",
                        "Executes P twice, with X1 and X2 on top of the stack.\nReturns the two values R1 and R2." },

                { "unary3", unary3_, "X1 X2 X3 [P]  ->  R1 R2 R3", "Executes P three times, with Xi, returns Ri (i = 1..3)." },

                { "unary4", unary4_, "X1 X2 X3 X4 [P]  ->  R1 R2 R3 R4", "Executes P four times, with Xi, returns Ri (i = 1..4)." },

                { "app2", unary2_, "X1 X2 [P]  ->  R1 R2", "Obsolescent.  == unary2" },

                { "app3", unary3_, "X1 X2 X3 [P]  ->  R1 R2 R3", "Obsolescent.  == unary3" },

                { "app4", unary4_, "X1 X2 X3 X4 [P]  ->  R1 R2 R3 R4", "Obsolescent.  == unary4" },

                { "binary", binary_, "X Y [P]  ->  R",
                        "Executes P, which leaves R on top of the stack.\nNo matter how many parameters this consumes,\nexactly two are removed from the stack." },

                { "ternary", ternary_, "X Y Z [P]  ->  R", "Executes P, which leaves R on top of the stack.\nNo matter how many parameters this consumes,\nexactly three are removed from the stack." },
                { "cleave", cleave_, "X [P1] [P2]  ->  R1 R2", "Executes P1 and P2, each with X on top, producing two results." },
                { "branch", branch_, "B [T] [F]  ->  ...", "If B is true, then executes T else executes F." },
                { "ifte", ifte_, "[B] [T] [F]  ->  ...", "Executes B. If that yields true, then executes T else executes F." },
                { "ifinteger", ifinteger_, "X [T] [E]  ->  ...", "If X is an integer, executes T else executes E." },
                { "ifchar", ifchar_, "X [T] [E]  ->  ...", "If X is a character, executes T else executes E." },
                { "iflogical", iflogical_, "X [T] [E]  ->  ...", "If X is a logical or truth value, executes T else executes E." },
                { "ifset", ifset_, "X [T] [E]  ->  ...", "If X is a set, executes T else executes E." },
                { "ifstring", ifstring_, "X [T] [E]  ->  ...", "If X is a string, executes T else executes E." },
                { "iflist", iflist_, "X [T] [E]  ->  ...", "If X is a list, executes T else executes E." },
                { "iffloat", iffloat_, "X [T] [E]  ->  ...", "If X is a float, executes T else executes E." },
                { "iffile", iffile_, "X [T] [E]  ->  ...", "If X is a file, executes T else executes E." },
                { "cond", cond_, "[..[[Bi] Ti]..[D]]  ->  ...", "Tries each Bi. If that yields true, then executes Ti and exits.\nIf no Bi yields true, executes default D." },
                { "while", while_, "[B] [D]  ->  ...", "While executing B yields true executes D." },
                { "linrec", linrec_, "[P] [T] [R1] [R2]  ->  ...", "Executes P. If that yields true, executes T.\nElse executes R1, recurses, executes R2." },
                { "tailrec", tailrec_, "[P] [T] [R1]  ->  ...", "Executes P. If that yields true, executes T.\nElse executes R1, recurses." },
                { "binrec", binrec_, "[B] [T] [R1] [R2]  ->  ...", "Executes P. If that yields true, executes T.\nElse uses R1 to produce two intermediates, recurses on both,\nthen executes R2 to combines their results." },
                { "genrec", genrec_, "[B] [T] [R1] [R2]  ->  ...", "Executes B, if that yields true executes T.\nElse executes R1 and then [[B] [T] [R1] [R2] genrec] R2." },
                {
                        "condnestrec",
                        condnestrec_,
                        "[ [C1] [C2] .. [D] ]  ->  ...",
                        "A generalisation of condlinrec. Each [Ci] is of the form [[B] [R1] [R2] .. [Rn]] and [D] is of the form [[R1] [R2] .. [Rn]]. Tries each B, or if all fail, takes the default [D]. For the case taken, executes each [Ri] but recurses between any two consecutive [Ri]. (n > 3 would be exceptional.)" },

                {
                        "condlinrec",
                        condlinrec_,
                        "[ [C1] [C2] .. [D] ]  ->  ...",
                        "Each [Ci] is of the forms [[B] [T]] or [[B] [R1] [R2]].\nTries each B. If that yields true and there is just a [T], executes T and exit.\nIf there are [R1] and [R2], executes R1, recurses, executes R2.\nSubsequent case are ignored. If no B yields true, then [D] is used.\nIt is then of the forms [[T]] or [[R1] [R2]]. For the former, executes T.\nFor the latter executes R1, recurses, executes R2." },

                { "step", step_, "A  [P]  ->  ...",
                        "Sequentially putting members of aggregate A onto stack,\nexecutes P for each member of A." },

                { "fold", fold_, "A V0 [P]  ->  V",
                        "Starting with value V0, sequentially pushes members of aggregate A\nand combines with binary operator P to produce value V." },

                { "map", map_, "A [P]  ->  B",
                        "Executes P on each member of aggregate A,\ncollects results in sametype aggregate B." },

                { "times", times_, "N [P]  ->  ...", "N times executes P." },

                {
                        "infra",
                        infra_,
                        "L1 [P]  ->  L2",
                        "Using list L1 as stack, executes P and returns a new list L2.\nThe first element of L1 is used as the top of stack,\nand after execution of P the top of stack becomes the first element of L2." },

                {
                        "primrec",
                        primrec_,
                        "X [I] [C]  ->  R",
                        "Executes I to obtain an initial value R0.\nFor integer X uses increasing positive integers to X, combines by C for new R.\nFor aggregate X uses successive members and combines by C for new R." },
                { "filter", filter_, "A [B]  ->  A1", "Uses test B to filter aggregate A producing sametype aggregate A1." },
                { "split", split_, "A [B]  ->  A1 A2", "Uses test B to split aggregate A into sametype aggregates A1 and A2 ." },
                { "some", some_, "A  [B]  ->  X", "Applies test B to members of aggregate A, X = true if some pass." },
                { "all", all_, "A [B]  ->  X", "Applies test B to members of aggregate A, X = true if all pass." },
                { "treestep", treestep_, "T [P]  ->  ...", "Recursively traverses leaves of tree T, executes P for each leaf." },
                { "treerec", treerec_, "T [O] [C]  ->  ...",
                        "T is a tree. If T is a leaf, executes O. Else executes [[O] [C] treerec] C." },
                { "treegenrec", treegenrec_, "T [O1] [O2] [C]  ->  ...",
                        "T is a tree. If T is a leaf, executes O1.\nElse executes O2 and then [[O1] [O2] [C] treegenrec] C." },

                /* MISCELLANEOUS */
                { "help", help1_, "->", "Lists all defined symbols, including those from library files.\nThen lists all primitives of raw Joy\n(There is a variant: \"_help\" which lists hidden symbols)." },
                { "_help", h_help1_, "->", "Lists all hidden symbols in library and then all hidden inbuilt symbols." },
                { "helpdetail", helpdetail_, "[ S1  S2  .. ]", "Gives brief help on each symbol S in the list." },
                { "manual", plain_manual_, "->", "Writes this manual of all Joy primitives to output file." },
                { "__html_manual", html_manual_, "->", "Writes this manual of all Joy primitives to output file in HTML style." },
                { "__latex_manual", latex_manual_, "->",
                        "Writes this manual of all Joy primitives to output file in Latex style but without the head and tail." },

                { "__manual_list", manual_list_aux_, "->  L",
                        "Pushes a list L of lists (one per operator) of three documentation strings" },

                { "__settracegc", settracegc_, "I  ->", "Sets value of flag for tracing garbage collection to I (= 0..5)." },

                { "setautoput", setautoput_, "I  ->",
                        "Sets value of flag for automatic put to I (if I = 0, none;\nif I = 1, put; if I = 2, stack." },

                { "setundeferror", setundeferror_, "I  ->",
                        "Sets flag that controls behavior of undefined functions\n(0 = no error, 1 = error)." },

                { "setecho", setecho_, "I ->",
                        "Sets value of echo flag for listing.\nI = 0: no echo, 1: echo, 2: with tab, 3: and linenumber." },

                { "gc", gc_, "->", "Initiates garbage collection." },

                {
                        "system",
                        system_,
                        "\"command\"  ->",
                        "Escapes to shell, executes string \"command\".\nThe string may cause execution of another program.\nWhen that has finished, the process returns to Joy." },

                { "getenv", getenv_, "\"variable\"  ->  \"value\"", "Retrieves the value of the environment variable \"variable\"." },

                { "argv", argv_, "-> A", "Creates an aggregate A containing the interpreter's command line arguments." },

                { "argc", argc_, "-> I", "Pushes the number of command line arguments. This is quivalent to 'argv size'." },

                { "__memoryindex", memoryindex_, "->", "Pushes current value of memory." },

                { "get", get_, "->  F", "Reads a factor from input and pushes it onto stack." },

                { "put", put_, "X  ->", "Writes X to output, pops X off stack." },

                { "putch", putch_, "N  ->", "N : numeric, writes character whose ASCII is N." },

                { "putchars", putchars_, "\"abc..\"  ->", "Writes  abc.. (without quotes)" },

                { "include", include_, "\"filnam.ext\"  ->",
                        "Transfers input to file whose name is \"filnam.ext\".\nOn end-of-file returns to previous input file." },

                { "abort", abortexecution_, "->", "Aborts execution of current Joy program, returns to Joy main cycle." },

                { "quit", quit_, "->", "Exit from Joy." },

                { 0, dummy_, "->", "->" } };

void inisymboltable(void) /* initialise         */
{
    int i;
    char *s;
    symtabindex = symtab;
    for (i = 0; i < HASHSIZE; hashentry[i++] = symtab)
        ;
    localentry = symtab;
    for (i = 0; optable[i].name; i++) {
        s = optable[i].name;
        /* ensure same algorithm in getsym */
        for (hashvalue = 0; *s != '\0';)
            hashvalue += *s++;
        hashvalue %= HASHSIZE;
        symtabindex->name = optable[i].name;
        symtabindex->u.proc = optable[i].proc;
        symtabindex->next = hashentry[hashvalue];
        hashentry[hashvalue] = symtabindex;
        D( printf("entered %s in symbol table at %ld = %ld\n",
                        symtabindex->name, (long)symtabindex,
                        LOC2INT(symtabindex)); )
        symtabindex++;
    }
    firstlibra = symtabindex;
}
static void helpdetail_() {
    Node *n;
    ONEPARAM("HELP");
    LIST("HELP");
    printf("\n");
    n = stk->u.lis;
    while (n != NULL) {
        if (n->op == USR_) {
            printf("%s  ==\n    ", n->u.ent->name);
            writeterm(n->u.ent->u.body, stdout);
            printf("\n");
            break;
        } else
            printf("%s        :   %s.\n%s\n", optable[(int) n->op].name, optable[(int) n->op].messg1, optable[(int) n->op].messg2);
        printf("\n");
        n = n->next;
    }
    POP(stk);
}
#define PLAIN (style == 0)
#define HTML (style == 1)
#define LATEX (style == 2)
#define HEADER(N,NAME,HEAD)                 \
    if (strcmp(N,NAME) == 0)                    \
      { printf("\n\n");                     \
        if (LATEX) printf("\\item[--- \\BX{");              \
    printf("%s",HEAD);                  \
    if (LATEX) printf("} ---] \\verb# #");              \
    printf("\n\n"); }
static void make_manual(int style /* 0=plain, 1=HTML, 2=Latex */) {
    int i;
    char * n;
    if (HTML)
        printf("<HTML>\n<DL>\n");
    for (i = BOOLEAN_; optable[i].name != 0; i++) {
        n = optable[i].name;
        HEADER(n," truth value type","literal")
        else HEADER(n,"false","operand")
        else HEADER(n,"id","operator")
        else HEADER(n,"null","predicate")
        else HEADER(n,"i","combinator")
        else HEADER(n,"help","miscellaneous commands")
        if (n[0] != '_') {
            if (HTML)
                printf("\n<DT>");
            else if (LATEX) {
                if (n[0] == ' ') {
                    n++;
                    printf("\\item[\\BX{");
                } else
                    printf("\\item[\\JX{");
            }
            if (HTML && strcmp(n, "<=") == 0)
                printf("&lt;=");
            else
                printf("%s", n);
            if (LATEX)
                printf("}]  \\verb#");
            if (HTML)
                printf(" <CODE>      :  </CODE> ");
            /* the above line does not produce the spaces around ":" */
            else
                printf("      :  ");
            printf("%s", optable[i].messg1);
            if (HTML)
                printf("\n<DD>");
            else if (LATEX)
                printf("# \\\\ \n {\\small\\verb#");
            else
                printf("\n");
            printf("%s", optable[i].messg2);
            if (LATEX)
                printf("#}");
            printf("\n\n");
        }
    }
    if (HTML)
        printf("\n</DL>\n</HTML>\n");
}

static void manual_list_() {

    int i = -1;
    Node *tmp;
    Node *n = NULL;
    while (optable[++i].name) {
        ; /* find end */
    }
    --i;
    while (i) {
        tmp = (optable[i].messg2, NULL);
        tmp = (optable[i].messg1, tmp);
        tmp = (optable[i].name, tmp);
        n = LIST_NEWNODE(tmp, n);
        --i;
    }
    stk = LIST_NEWNODE(n, stk);
}
char *opername(int o) {
    return optable[(short) o].name;
}

/* END of INTERP.C */
